home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / lifeos2.zip / LIFE-1.02 / SOURCE / BUILT_IN.C < prev    next >
C/C++ Source or Header  |  1996-06-16  |  143KB  |  6,276 lines
  1. /* Copyright 1991 Digital Equipment Corporation.
  2. ** All Rights Reserved.
  3. *****************************************************************/
  4. /*     $Id: built_ins.c,v 1.14 1995/07/27 21:26:28 duchier Exp $     */
  5.  
  6. #ifndef lint
  7. static char vcid[] = "$Id: built_ins.c,v 1.14 1995/07/27 21:26:28 duchier Exp $";
  8. #endif /* lint */
  9. #ifdef OS2_PORT
  10. #include <direct.h>
  11. #endif
  12. #include "extern.h"
  13. #include "trees.h"
  14. #include "login.h"
  15. #include "types.h"
  16. #include "parser.h"
  17. #include "copy.h"
  18. #include "token.h"
  19. #include "print.h"
  20. #include "lefun.h"
  21. #include "memory.h"
  22. #ifndef OS2_PORT
  23. #include "built_ins.h"
  24. #else
  25. #include "built_in.h"
  26. #endif
  27. #include "error.h" 
  28. #include "modules.h"  /*  RM: Jan  8 1993  */
  29.  
  30. #ifdef X11
  31. #include "xpred.h"
  32. #endif
  33.  
  34. #ifdef SOLARIS
  35. #include <stdlib.h>
  36. static unsigned int randomseed;
  37. #endif
  38.  
  39.  
  40. long (* c_rule[MAX_BUILT_INS])();
  41.  
  42. ptr_definition abortsym; /* 26.1 */
  43. ptr_definition aborthooksym; /* 26.1 */
  44.  
  45. ptr_definition add_module1;  /*  RM: Mar 12 1993  */
  46. ptr_definition add_module2;
  47. ptr_definition add_module3;
  48.  
  49. ptr_definition and;
  50. ptr_definition apply;
  51. ptr_definition boolean;
  52. ptr_definition boolpredsym;
  53. ptr_definition built_in;
  54. ptr_definition calloncesym;
  55. ptr_definition colonsym;
  56. ptr_definition commasym;
  57. ptr_definition comment;
  58. /* ptr_definition conjunction; 19.8 */
  59. ptr_definition constant;
  60. ptr_definition cut;
  61. ptr_definition disjunction;
  62. ptr_definition disj_nil;/*  RM: Feb  1 1993  */
  63. ptr_definition eof;
  64. ptr_definition eqsym;
  65. ptr_definition leftarrowsym;
  66. ptr_definition false;
  67. ptr_definition funcsym;
  68. ptr_definition functor;
  69. ptr_definition iff;
  70. ptr_definition integer;
  71. ptr_definition alist;
  72. ptr_definition life_or; /*  RM: Apr  6 1993  */
  73. ptr_definition minus_symbol; /*  RM: Jun 21 1993  */
  74. ptr_definition nil; /*** RM 9 Dec 1992 ***/
  75. ptr_definition nothing;
  76. ptr_definition predsym;
  77. ptr_definition quote;
  78. ptr_definition quoted_string;
  79. ptr_definition real;
  80. ptr_definition stream;
  81. ptr_definition succeed;
  82. ptr_definition such_that;
  83. ptr_definition top;
  84. ptr_definition true;
  85. ptr_definition timesym;
  86. ptr_definition tracesym; /* 26.1 */
  87. ptr_definition typesym;
  88. ptr_definition variable;
  89. ptr_definition opsym;
  90. ptr_definition loadsym;
  91. ptr_definition dynamicsym;
  92. ptr_definition staticsym;
  93. ptr_definition encodesym;
  94. ptr_definition listingsym;
  95. /* ptr_definition provesym; */
  96. ptr_definition delay_checksym;
  97. ptr_definition eval_argsym;
  98. ptr_definition inputfilesym;
  99. ptr_definition call_handlersym;
  100. ptr_definition xf_sym;
  101. ptr_definition fx_sym;
  102. ptr_definition yf_sym;
  103. ptr_definition fy_sym;
  104. ptr_definition xfx_sym;
  105. ptr_definition xfy_sym;
  106. ptr_definition yfx_sym;
  107. ptr_definition nullsym;
  108.  
  109.  
  110. /*  RM: Jul  7 1993  */
  111. ptr_definition final_dot;
  112. ptr_definition final_question;
  113.  
  114.  
  115. ptr_psi_term null_psi_term;
  116.  
  117. char *one;
  118. char *two;
  119. char *three;
  120. char *year_attr;
  121. char *month_attr;
  122. char *day_attr;
  123. char *hour_attr;
  124. char *minute_attr;
  125. char *second_attr;
  126. char *weekday_attr;
  127.  
  128. static long built_in_index=0;
  129.  
  130. int all_public_symbols();  /* RM: Jan 28 1994  */
  131.  
  132. /*  RM: Sep 20 1993  */
  133. int arg_c;
  134. char **arg_v;
  135.  
  136.  
  137.  
  138. /***  RM: Dec  9 1992  (START) ***/
  139.  
  140. /********* STACK_NIL
  141.   Create the NIL object on the stack.
  142.   */
  143.  
  144. ptr_psi_term stack_nil()
  145.  
  146. {
  147.   ptr_psi_term empty;
  148.  
  149.   
  150.   empty=stack_psi_term(4);
  151.   empty->type=nil;
  152.  
  153.   return empty;
  154. }
  155.  
  156.  
  157.  
  158. /******** STACK_CONS(head,tail)
  159.   Create a CONS object.
  160.   */
  161.  
  162. ptr_psi_term stack_cons(head,tail)
  163.      ptr_psi_term head;
  164.      ptr_psi_term tail;
  165. {
  166.   ptr_psi_term cons;
  167.  
  168.   cons=stack_psi_term(4);
  169.   cons->type=alist;
  170.   if(head)
  171.     stack_insert(featcmp,one,&(cons->attr_list),head);
  172.   if(tail)
  173.     stack_insert(featcmp,two,&(cons->attr_list),tail);
  174.  
  175.   return cons;
  176. }
  177.  
  178. /********* STACK_PAIR(left,right)
  179.   create a PAIR object.
  180.   */
  181.  
  182. ptr_psi_term stack_pair(left,right)
  183.      ptr_psi_term left;
  184.      ptr_psi_term right;
  185. {
  186.   ptr_psi_term pair;
  187.  
  188.   pair=stack_psi_term(4);
  189.   pair->type=and;
  190.   if(left)
  191.     stack_insert(featcmp,one,&(pair->attr_list),left);
  192.   if(right)
  193.     stack_insert(featcmp,two,&(pair->attr_list),right);
  194.  
  195.   return pair;
  196. }
  197.  
  198. /********* STACK_INT(n)
  199.   create an INT object
  200.   */
  201.  
  202. ptr_psi_term stack_int(n)
  203.      long n;
  204. {
  205.   ptr_psi_term m;
  206.   m=stack_psi_term(4);
  207.   m->type=integer;
  208.   m->value=heap_alloc(sizeof(REAL));
  209.   *(REAL *)m->value=(REAL)n;
  210.   return m;
  211. }
  212.  
  213. /********* STACK_STRING(s)
  214.   create a STRING object
  215.   */
  216.  
  217. ptr_psi_term stack_string(s)
  218.      char *s;
  219. {
  220.   ptr_psi_term t = stack_psi_term(4);
  221.   t->type = quoted_string;
  222.   t->value=(GENERIC)heap_copy_string(s);
  223.   return t;
  224. }
  225.  
  226. /***  RM: Dec  9 1992  (END) ***/
  227.  
  228. /********* STACK_BYTES(s,n)
  229.   create a STRING object given a sequence of bytes
  230.   */
  231.  
  232. ptr_psi_term stack_bytes(s,n)
  233.      char *s;
  234.      int n;
  235. {
  236.   ptr_psi_term t = stack_psi_term(4);
  237.   t->type = quoted_string;
  238.   t->value=(GENERIC)heap_ncopy_string(s,n);
  239.   return t;
  240. }
  241.  
  242.   
  243.  
  244. /********* PSI_TO_STRING(t,fn)
  245.   Get the value of a Life string, or the name of a non-string psi-term.
  246.   Return TRUE iff a valid string is found.
  247. */
  248. long psi_to_string(t, fn)
  249. ptr_psi_term t;
  250. char **fn;
  251. {
  252.   if (equal_types(t->type,quoted_string)) {
  253.     if (t->value) {
  254.       *fn = (char *) t->value;
  255.       return TRUE;
  256.     }
  257.     else {
  258.       *fn = quoted_string->keyword->symbol;
  259.       return TRUE;
  260.     }
  261.   }
  262.   else {
  263.     *fn = t->type->keyword->symbol;
  264.     return TRUE;
  265.   }
  266. }
  267.  
  268.  
  269. /***  RM: Dec  9 1992  (START) ***/
  270.  
  271. ptr_psi_term make_feature_list(tree,tail,module,val)
  272.      
  273.      ptr_node tree;
  274.      ptr_psi_term tail;
  275.      ptr_module module;
  276.      int val;
  277.      
  278. {
  279.   ptr_psi_term new;
  280.   ptr_definition def;
  281.   double d, strtod();
  282.   
  283.   
  284.   if(tree) {
  285.     if(tree->right)
  286.       tail=make_feature_list(tree->right,tail,module,val);
  287.  
  288.     /* Insert the feature name into the list */
  289.     
  290.     d=str_to_int(tree->key);
  291.     if (d== -1) { /* Feature is not a number */
  292.       def=update_feature(module,tree->key); /* Extract module RM: Feb 3 1993 */
  293.       if(def) {
  294.     if(val) /* RM: Mar  3 1994 Distinguish between features & values */
  295.       tail=stack_cons(tree->data,tail);
  296.     else {
  297.       new=stack_psi_term(4);      
  298.       new->type=def;
  299.       tail=stack_cons(new,tail);
  300.     }
  301.       }
  302.     }
  303.     else { /* Feature is a number */
  304.       if(val) /* RM: Mar  3 1994 Distinguish between features & values */
  305.     tail=stack_cons(tree->data,tail);
  306.       else {
  307.     new=stack_psi_term(4);      
  308.     new->type=(d==floor(d))?integer:real;
  309.     new->value=heap_alloc(sizeof(REAL));
  310.     *(REAL *)new->value=(REAL)d;
  311.     tail=stack_cons(new,tail);
  312.       }
  313.     }
  314.     
  315.     if(tree->left)
  316.       tail=make_feature_list(tree->left,tail,module,val);
  317.   }
  318.   
  319.   return tail;
  320. }
  321.  
  322. /***  RM: Dec  9 1992  (END) ***/
  323.  
  324.  
  325.  
  326.  
  327.  
  328.  
  329. /******** CHECK_REAL(t,v,n)
  330.   Like get_real_value, but does not force the type of T to be real.
  331. */
  332. long check_real(t,v,n)
  333. ptr_psi_term t;
  334. REAL *v;
  335. long *n;
  336. {
  337.   long success=FALSE;
  338.   long smaller;
  339.  
  340.   if (t) {
  341.     success=matches(t->type,real,&smaller);
  342.     if (success) {
  343.       *n=FALSE;
  344.       if (smaller && t->value) {
  345.         *v= *(REAL *)t->value;
  346.         *n=TRUE;
  347.       }
  348.     }
  349.   }
  350.   return success;
  351. }
  352.  
  353.  
  354.  
  355. /******** GET_REAL_VALUE(t,v,n)
  356.   Check if psi_term T is a real number.  Return N=TRUE iff T <| REAL.
  357.   If T has a real value then set V to that value.
  358.   Also force the type of T to REAL if REAL <| T.
  359.   This is used in all the arithmetic built-in functions to get their arguments.
  360. */
  361. long get_real_value(t,v,n)
  362. ptr_psi_term t;
  363. REAL *v;
  364. long *n;
  365. {
  366.   long success=FALSE;
  367.   long smaller;
  368.   
  369.   if (t) {
  370.     success=matches(t->type,real,&smaller);
  371.     if (success) {
  372.       *n=FALSE;
  373.       if (smaller) {
  374.     if (t->value) {
  375.       *v= *(REAL *)t->value;
  376.       *n=TRUE;
  377.     }
  378.       }
  379.       else {
  380.     if((GENERIC)t<heap_pointer) { /*  RM: Jun  8 1993  */
  381.       push_ptr_value(def_ptr,&(t->type));
  382.       push_ptr_value(int_ptr,&(t->status));
  383.       t->type=real;
  384.       t->status=0;
  385.       i_check_out(t);
  386.     }
  387.       }
  388.     }
  389.   }
  390.   return success;
  391. }
  392.  
  393.  
  394.  
  395. /******** GET_BOOL_VALUE(t,v,n)
  396.   This is identical in nature to
  397.   GET_REAL_VALUE. The values handled here have to be booleans.
  398.   Check if psi_term T is a boolean. V <- TRUE or FALSE value of T.
  399. */
  400. static long get_bool_value(t,v,n)
  401. ptr_psi_term t;
  402. REAL *v;
  403. long *n;
  404. {
  405.   long success=FALSE;
  406.   long smaller;
  407.   
  408.   
  409.   if(t) {
  410.     success=matches(t->type,boolean,&smaller);
  411.     if(success) {
  412.       *n=FALSE;
  413.       if(smaller) {
  414.     if(matches(t->type,false,&smaller) && smaller) {
  415.       *v= 0;
  416.       *n=TRUE;
  417.     }
  418.     else
  419.       if(matches(t->type,true,&smaller) && smaller) {
  420.         *v= 1;
  421.         *n=TRUE;
  422.       }
  423.       }
  424.       else {
  425.     if((GENERIC)t<heap_pointer) { /*  RM: Jun  8 1993  */
  426.       push_ptr_value(def_ptr,&(t->type));
  427.       push_ptr_value(int_ptr,&(t->status));
  428.       t->type=boolean;
  429.       t->status=0;
  430.       i_check_out(t);
  431.     }
  432.       }      
  433.     }
  434.   }
  435.   
  436.   return success;
  437. }
  438.  
  439.  
  440.  
  441. /******** UNIFY_BOOL_RESULT(t,v)
  442.   Unify psi_term T to the boolean value V = TRUE or FALSE.
  443.   This is used by built-in logical functions to return their result.
  444. */
  445. void unify_bool_result(t,v)
  446. ptr_psi_term t;
  447. long v;
  448. {
  449.   ptr_psi_term u;
  450.  
  451.   u=stack_psi_term(4);
  452.   u->type=v?true:false;
  453.   push_goal(unify,t,u,NULL);
  454.   
  455.   /* Completely commented out by Richard on Nov 25th 1993
  456.      What's *your* Birthday? Maybe you'd like a Birthday-Bug-Card!
  457.      
  458.   if((GENERIC)t<heap_pointer) {
  459.     push_ptr_value(def_ptr,&(t->type));
  460.     if (v) {
  461.       t->type=true;
  462.       t->status=0;
  463.     }
  464.     else {
  465.       t->type=false;
  466.       t->status=0;
  467.     }
  468.   
  469.     i_check_out(t);
  470.     if (t->resid)
  471.       release_resid(t);
  472.   }
  473.   else {
  474.     Warningline("the persistent term '%P' appears in a boolean constraint and cannot be refined\n",t);
  475.     }
  476.     */
  477. }
  478.  
  479.  
  480.  
  481.  
  482. /******** UNIFY_REAL_RESULT(t,v)
  483.   Unify psi_term T to the real value V.
  484.   This is used by built-in arithmetic functions to return their result.
  485. */
  486. long unify_real_result(t,v)
  487. ptr_psi_term t;
  488. REAL v;
  489. {
  490.   long smaller;
  491.   long success=TRUE;
  492.  
  493. #ifdef prlDEBUG
  494.   if (t->value) {
  495.     printf("*** BUG: value already present in UNIFY_REAL_RESULT\n");
  496.   }
  497. #endif
  498.  
  499.   if((GENERIC)t<heap_pointer) { /*  RM: Jun  8 1993  */
  500.     deref_ptr(t);
  501.     assert(t->value==NULL); /* 10.6 */
  502.     push_ptr_value(int_ptr,&(t->value));
  503.     t->value=heap_alloc(sizeof(REAL)); /* 12.5 */
  504.     *(REAL *)t->value = v;
  505.     
  506.     matches(t->type,integer,&smaller);
  507.     
  508.     if (v==floor(v)){
  509.       if (!smaller) {
  510.     push_ptr_value(def_ptr,&(t->type));
  511.     t->type=integer;
  512.     t->status=0;
  513.       }
  514.     }
  515.     else
  516.       if (smaller)
  517.     success=FALSE;
  518.     
  519.     if (success) {
  520.       i_check_out(t);
  521.       if (t->resid)
  522.     release_resid(t);
  523.     }
  524.   }
  525.   else {
  526.     Warningline("the persistent term '%P' appears in an arithmetic constraint and cannot be refined\n",t);
  527.   }
  528.   
  529.   return success;
  530. }
  531.  
  532.  
  533.  
  534. /******** C_GT
  535.   Greater than.
  536. */
  537. static long c_gt()
  538. {
  539.   long success=TRUE;
  540.   ptr_psi_term arg1,arg2,arg3,t;
  541.   long num1,num2,num3;
  542.   REAL val1,val2,val3;
  543.   
  544.   t=aim->a;
  545.   deref_ptr(t);
  546.   get_two_args(t->attr_list,&arg1,&arg2);
  547.   arg3=aim->b;
  548.   
  549.   if (arg1) {
  550.     deref(arg1);
  551.     success=get_real_value(arg1,&val1,&num1);
  552.     if(success && arg2) {
  553.       deref(arg2);
  554.       deref_args(t,set_1_2);
  555.       success=get_real_value(arg2,&val2,&num2);
  556.     }
  557.   }
  558.   
  559.   if(success)
  560.     if(arg1 && arg2) {
  561.       deref(arg3);
  562.       success=get_bool_value(arg3,&val3,&num3);
  563.       if(success)
  564.     switch(num1+num2*2+num3*4) {
  565.     case 0:
  566.       residuate2(arg1,arg2);
  567.       break;
  568.     case 1:
  569.       residuate(arg2);
  570.       break;
  571.     case 2:
  572.       residuate(arg1);
  573.       break;
  574.     case 3:
  575.       unify_bool_result(arg3,(val1>val2));
  576.       break;
  577.     case 4:
  578.       residuate2(arg1,arg2);
  579.       break;
  580.     case 5:
  581.       residuate(arg2);
  582.       break;
  583.     case 6:
  584.       residuate(arg1);
  585.       break;
  586.     case 7:
  587.       success=(val3==(REAL)(val1>val2));
  588.       break;
  589.     } 
  590.     }
  591.     else
  592.       curry();
  593.   
  594.   nonnum_warning(t,arg1,arg2);
  595.   return success;
  596. }
  597.  
  598.  
  599.  
  600. /******** C_EQUAL
  601.   Arithmetic equality.
  602. */
  603. static long c_equal()
  604. {
  605.   long success=TRUE;
  606.   ptr_psi_term arg1,arg2,arg3,t;
  607.   long num1,num2,num3;
  608.   REAL val1,val2,val3;
  609.   
  610.   t=aim->a;
  611.   deref_ptr(t);
  612.   get_two_args(t->attr_list,&arg1,&arg2);
  613.   arg3=aim->b;
  614.   
  615.   if(arg1) {
  616.     deref(arg1);
  617.     success=get_real_value(arg1,&val1,&num1);
  618.     if(success && arg2) {
  619.       deref(arg2);
  620.       deref_args(t,set_1_2);
  621.       success=get_real_value(arg2,&val2,&num2);
  622.     }
  623.   }
  624.   
  625.   if(success)
  626.     if(arg1 && arg2) {
  627.       deref(arg3);
  628.       success=get_bool_value(arg3,&val3,&num3);
  629.       if(success)
  630.     switch(num1+2*num2+4*num3) {
  631.     case 0:
  632.       if(arg1==arg2)
  633.         unify_bool_result(arg3,TRUE);
  634.       else
  635.         residuate2(arg1,arg2);
  636.       break;
  637.     case 1:
  638.       residuate2(arg2,arg3);
  639.       break;
  640.     case 2:
  641.       residuate2(arg1,arg3);
  642.       break;
  643.     case 3:
  644.       unify_bool_result(arg3,(val1==val2));
  645.       break;
  646.     case 4:
  647.       if(arg1==arg2 && !val3)
  648.         success=FALSE;
  649.       else
  650.         residuate2(arg1,arg2);
  651.       break;
  652.     case 5:
  653.       if(!val3)
  654.         residuate(arg2);
  655.       else
  656.         success=unify_real_result(arg2,val1);
  657.       break;
  658.     case 6:
  659.       if(!val3)
  660.         residuate(arg1);
  661.       else
  662.         success=unify_real_result(arg1,val2);
  663.       break;
  664.     case 7:
  665.       success=(val3==(REAL)(val1==val2));
  666.       break;
  667.     }
  668.     }
  669.     else
  670.       curry();
  671.   
  672.   nonnum_warning(t,arg1,arg2);
  673.   return success;
  674. }
  675.  
  676.  
  677.  
  678. /*** RM: 9 Dec 1992 (START) ***/
  679.  
  680. /******** C_EVAL_DISJUNCTION
  681.   Evaluate a disjunction.
  682.   */
  683.  
  684. static long c_eval_disjunction()
  685.      
  686. {
  687.   ptr_psi_term arg1,arg2,funct,result;
  688.  
  689.   
  690.   funct=aim->a;
  691.   deref_ptr(funct);
  692.   result=aim->b;
  693.   get_two_args(funct->attr_list,&arg1,&arg2);
  694.  
  695.   /* deref_args(funct,set_1_2); Don't know about this */
  696.   
  697.   if (arg1 && arg2) {
  698.     deref_ptr(arg1);
  699.     deref_ptr(arg2);
  700.  
  701.     resid_aim=NULL; /* Function evaluation is over */
  702.  
  703.     if(arg2->type!=disj_nil) /*  RM: Feb  1 1993  */
  704.       /* Create the alternative */
  705.       push_choice_point(eval,arg2,result,funct->type->rule);
  706.     
  707.     /* Unify the result with the first argument */
  708.     push_goal(unify,result,arg1,NULL);
  709.     i_check_out(arg1);
  710.   }
  711.   else {
  712.     Errorline("malformed disjunction '%P'\n",funct);
  713.     return (c_abort());
  714.   }
  715.   
  716.   return TRUE;
  717. }
  718.  
  719. /*** RM: 9 Dec 1992 (END) ***/
  720.  
  721.   
  722.  
  723.  
  724.   
  725. /******** C_LT
  726.   Less than.
  727. */
  728. static long c_lt()
  729. {
  730.   long success=TRUE;
  731.   ptr_psi_term arg1,arg2,arg3,t;
  732.   long num1,num2,num3;
  733.   REAL val1,val2,val3;
  734.   
  735.   t=aim->a;
  736.   deref_ptr(t);
  737.   get_two_args(t->attr_list,&arg1,&arg2);
  738.   arg3=aim->b;
  739.   
  740.   if(arg1) {
  741.     deref(arg1);
  742.     success=get_real_value(arg1,&val1,&num1);
  743.     if(success && arg2) {
  744.       deref(arg2);
  745.       deref_args(t,set_1_2);
  746.       success=get_real_value(arg2,&val2,&num2);
  747.     }
  748.   }
  749.   
  750.   if(success)
  751.     if(arg1 && arg2) {
  752.       deref(arg3);
  753.       success=get_bool_value(arg3,&val3,&num3);
  754.       if(success)
  755.     switch(num1+num2*2+num3*4) {
  756.     case 0:
  757.       residuate2(arg1,arg2);
  758.       break;
  759.     case 1:
  760.       residuate(arg2);
  761.       break;
  762.     case 2:
  763.       residuate(arg1);
  764.       break;
  765.     case 3:
  766.       unify_bool_result(arg3,(val1<val2));
  767.       break;
  768.     case 4:
  769.       residuate2(arg1,arg2);
  770.       break;
  771.     case 5:
  772.       residuate(arg2);
  773.       break;
  774.     case 6:
  775.       residuate(arg1);
  776.       break;
  777.     case 7:
  778.       success=(val3==(REAL)(val1<val2));
  779.       break;
  780.     }
  781.     }
  782.     else
  783.       curry();
  784.   
  785.   nonnum_warning(t,arg1,arg2);
  786.   return success;
  787. }
  788.  
  789.  
  790.  
  791.  
  792. /******** C_GTOE
  793.   Greater than or equal.
  794. */
  795. static long c_gtoe()
  796. {
  797.   long success=TRUE;
  798.   ptr_psi_term arg1,arg2,arg3,t;
  799.   long num1,num2,num3;
  800.   REAL val1,val2,val3;
  801.   
  802.   t=aim->a;
  803.   deref_ptr(t);
  804.   get_two_args(t->attr_list,&arg1,&arg2);
  805.   arg3=aim->b;
  806.   
  807.   if(arg1) {
  808.     deref(arg1);
  809.     success=get_real_value(arg1,&val1,&num1);
  810.     if(success && arg2) {
  811.       deref(arg2);
  812.       deref_args(t,set_1_2);
  813.       success=get_real_value(arg2,&val2,&num2);
  814.     }
  815.   }
  816.   
  817.   if(success)
  818.     if(arg1 && arg2) {
  819.       deref(arg3);
  820.       success=get_bool_value(arg3,&val3,&num3);
  821.       if(success)
  822.     switch(num1+num2*2+num3*4) {
  823.     case 0:
  824.       residuate2(arg1,arg2);
  825.       break;
  826.     case 1:
  827.       residuate(arg2);
  828.       break;
  829.     case 2:
  830.       residuate(arg1);
  831.       break;
  832.     case 3:
  833.       unify_bool_result(arg3,(val1>=val2));
  834.       break;
  835.     case 4:
  836.       residuate2(arg1,arg2);
  837.       break;
  838.     case 5:
  839.       residuate(arg2);
  840.       break;
  841.     case 6:
  842.       residuate(arg1);
  843.       break;
  844.     case 7:
  845.       success=(val3==(REAL)(val1>=val2));
  846.       break;
  847.     }      
  848.     }
  849.     else
  850.       curry();
  851.   
  852.   nonnum_warning(t,arg1,arg2);
  853.   return success;
  854. }
  855.  
  856.  
  857.  
  858. /******** C_LTOE
  859.   Less than or equal.
  860. */
  861. static long c_ltoe()
  862. {
  863.   long success=TRUE;
  864.   ptr_psi_term arg1,arg2,arg3,t;
  865.   long num1,num2,num3;
  866.   REAL val1,val2,val3;
  867.   
  868.   t=aim->a;
  869.   deref_ptr(t);
  870.   get_two_args(t->attr_list,&arg1,&arg2);
  871.   arg3=aim->b;
  872.   
  873.   if(arg1) {
  874.     deref(arg1);
  875.     success=get_real_value(arg1,&val1,&num1);
  876.     if(success && arg2) {
  877.       deref(arg2);
  878.       deref_args(t,set_1_2);
  879.       success=get_real_value(arg2,&val2,&num2);
  880.     }
  881.   }
  882.   
  883.   if(success)
  884.     if(arg1 && arg2) {
  885.       deref(arg3);
  886.       success=get_bool_value(arg3,&val3,&num3);
  887.       if(success)
  888.     switch(num1+num2*2+num3*4) {
  889.     case 0:
  890.       residuate2(arg1,arg2);
  891.       break;
  892.     case 1:
  893.       residuate(arg2);
  894.       break;
  895.     case 2:
  896.       residuate(arg1);
  897.       break;
  898.     case 3:
  899.       unify_bool_result(arg3,(val1<=val2));
  900.       break;
  901.     case 4:
  902.       residuate2(arg1,arg2);
  903.       break;
  904.     case 5:
  905.       residuate(arg2);
  906.       break;
  907.     case 6:
  908.       residuate(arg1);
  909.       break;
  910.     case 7:
  911.       success=(val3==(REAL)(val1<=val2));
  912.       break;
  913.     }
  914.     }
  915.     else
  916.       curry();
  917.   
  918.   nonnum_warning(t,arg1,arg2);
  919.   return success;
  920. }
  921.  
  922.  
  923.  
  924.  
  925. /******** C_BOOLPRED
  926.   Internal built-in predicate that handles functions in predicate positions.
  927.   This predicate should never be called directly by the user.
  928. */
  929.  
  930. static long c_boolpred()
  931. {
  932.   long success=TRUE,succ,lesseq;
  933.   ptr_psi_term t,arg1;
  934.  
  935.   t=aim->a;
  936.   deref_ptr(t);
  937.   get_one_arg(t->attr_list,&arg1);
  938.   if (arg1) {
  939.     deref(arg1);
  940.     deref_args(t,set_1);
  941.     if (sub_type(boolean,arg1->type)) {
  942.       residuate(arg1);
  943.     }
  944.     else {
  945.       succ=matches(arg1->type,true,&lesseq);
  946.       if (succ) {
  947.         if (lesseq) {
  948.           /* Function returns true: success. */
  949.         }
  950.         else
  951.           residuate(arg1);
  952.       }
  953.       else {
  954.         succ=matches(arg1->type,false,&lesseq);
  955.         if (succ) {
  956.           if (lesseq) {
  957.             /* Function returns false: failure. */
  958.             success=FALSE;
  959.           }
  960.           else
  961.             residuate(arg1);
  962.         }
  963.         else {
  964.           /* Both true and false are disentailed. */
  965.           if (arg1->type->type==predicate) {
  966.             push_goal(prove,arg1,DEFRULES,NULL);
  967.           }
  968.           else {
  969.             Errorline("function result '%P' should be a boolean or a predicate.\n",
  970.               arg1);
  971.             return (c_abort());
  972.           }
  973.         }
  974.       }
  975.     }
  976.   }
  977.   else {
  978.     Errorline("missing argument to '*boolpred*'.\n");
  979.     return (c_abort());
  980.   }
  981.  
  982.   return success;
  983. }
  984.  
  985. static long get_bool(typ)
  986. ptr_definition typ;
  987. {
  988.   if (sub_type(typ,true)) return TRUE;
  989.   else if (sub_type(typ,false)) return FALSE;
  990.   else return UNDEF;
  991. }
  992.  
  993. static long unify_bool(arg)
  994. ptr_psi_term arg;
  995. {
  996.   ptr_psi_term tmp;
  997.  
  998.   tmp=stack_psi_term(4);
  999.   tmp->type=boolean;
  1000.   push_goal(unify,tmp,arg,NULL);
  1001. }
  1002.  
  1003. /* Main routine to handle the and & or functions. */
  1004. /* sel = TRUE (for and) or FALSE (for or) */
  1005. static long c_logical_main(sel)
  1006. long sel;
  1007. {
  1008.   long success=TRUE;
  1009.   ptr_psi_term funct,arg1,arg2,arg3;
  1010.   long sm1, sm2, sm3;
  1011.   long a1comp, a2comp, a3comp;
  1012.   long a1, a2, a3;
  1013.  
  1014.   funct=aim->a;
  1015.   deref_ptr(funct);
  1016.   get_two_args(funct->attr_list,&arg1,&arg2);
  1017.   if (arg1 && arg2) {
  1018.     deref(arg1);
  1019.     deref(arg2);
  1020.     deref_args(funct,set_1_2);
  1021.     arg3=aim->b;
  1022.     deref(arg3);
  1023.  
  1024.     a1comp = matches(arg1->type,boolean,&sm1);
  1025.     a2comp = matches(arg2->type,boolean,&sm2);
  1026.     a3comp = matches(arg3->type,boolean,&sm3);
  1027.     if (a1comp && a2comp && a3comp) {
  1028.       a1 = get_bool(arg1->type);
  1029.       a2 = get_bool(arg2->type);
  1030.       a3 = get_bool(arg3->type);
  1031.       if (a1== !sel || a2== !sel) {
  1032.     unify_bool_result(arg3,!sel);
  1033.       } else if (a1==sel) {
  1034.     /* tmp=stack_psi_term(4); */
  1035.     /* tmp->type=boolean; */
  1036.     /* push_goal(unify,tmp,arg3,NULL); */
  1037.     push_goal(unify,arg2,arg3,NULL);
  1038.       } else if (a2==sel) {
  1039.     /* tmp=stack_psi_term(4); */
  1040.     /* tmp->type=boolean; */
  1041.     /* push_goal(unify,tmp,arg3,NULL); */
  1042.     push_goal(unify,arg1,arg3,NULL);
  1043.       } else if (a3==sel) {
  1044.     unify_bool_result(arg1,sel);
  1045.     unify_bool_result(arg2,sel);
  1046.       } else if (arg1==arg2) {
  1047.     /* tmp=stack_psi_term(4); */
  1048.     /* tmp->type=boolean; */
  1049.     /* push_goal(unify,tmp,arg3,NULL); */
  1050.     push_goal(unify,arg1,arg3,NULL);
  1051.       } else {
  1052.     if (a1==UNDEF) residuate(arg1);
  1053.     if (a2==UNDEF) residuate(arg2);
  1054.     if (a3==UNDEF) residuate(arg3);
  1055.       }
  1056.       if (!sm1) unify_bool(arg1);
  1057.       if (!sm2) unify_bool(arg2);
  1058.       if (!sm3) unify_bool(arg3);
  1059.     }
  1060.     else {
  1061.       success=FALSE;
  1062.       Errorline("Non-boolean argument or result in '%P'.\n",funct);
  1063.     }
  1064.   }
  1065.   else
  1066.     curry();
  1067.  
  1068.   return success;
  1069. }
  1070.  
  1071.  
  1072.  
  1073.  
  1074. /******** C_AND, C_OR
  1075.   Logical and & or.
  1076.   These functions do all possible local propagations.
  1077. */
  1078. static long c_and()
  1079. {
  1080.   return c_logical_main(TRUE);
  1081. }
  1082.  
  1083. static long c_or()
  1084. {
  1085.   return c_logical_main(FALSE);
  1086. }
  1087.  
  1088.  
  1089.  
  1090.  
  1091. /******** C_NOT
  1092.   Logical not.
  1093.   This function does all possible local propagations.
  1094. */
  1095. static long c_not()
  1096. {
  1097.   long success=TRUE;
  1098.   ptr_psi_term funct,arg1,arg2;
  1099.   long sm1, sm2;
  1100.   long a1comp, a2comp;
  1101.   long a1, a2;
  1102.  
  1103.   funct=aim->a;
  1104.   deref_ptr(funct);
  1105.   get_one_arg(funct->attr_list,&arg1);
  1106.   if (arg1) {
  1107.     deref(arg1);
  1108.     deref_args(funct,set_1);
  1109.     arg2=aim->b;
  1110.     deref(arg2);
  1111.  
  1112.     a1comp = matches(arg1->type,boolean,&sm1);
  1113.     a2comp = matches(arg2->type,boolean,&sm2);
  1114.     if (a1comp && a2comp) {
  1115.       a1 = get_bool(arg1->type);
  1116.       a2 = get_bool(arg2->type);
  1117.       if (a1==TRUE || a1==FALSE) {
  1118.     unify_bool_result(arg2,!a1);
  1119.       } else if (a2==TRUE || a2==FALSE) {
  1120.     unify_bool_result(arg1,!a2);
  1121.       } else if (arg1==arg2) {
  1122.     success=FALSE;
  1123.       } else {
  1124.     if (a1==UNDEF) residuate(arg1);
  1125.     if (a2==UNDEF) residuate(arg2);
  1126.       }
  1127.       if (!sm1) unify_bool(arg1);
  1128.       if (!sm2) unify_bool(arg2);
  1129.     }
  1130.     else {
  1131.       success=FALSE;
  1132.       Errorline("Non-boolean argument or result in '%P'.\n",funct);
  1133.     }
  1134.   }
  1135.   else
  1136.     curry();
  1137.  
  1138.   return success;
  1139. }
  1140.  
  1141.  
  1142.  
  1143.  
  1144. /******** C_XOR
  1145.   Logical exclusive or.
  1146.   This function does all possible local propagations.
  1147. */
  1148. static long c_xor()
  1149. {
  1150.   long success=TRUE;
  1151.   ptr_psi_term funct,arg1,arg2,arg3;
  1152.   long sm1, sm2, sm3;
  1153.   long a1comp, a2comp, a3comp;
  1154.   long a1, a2, a3;
  1155.  
  1156.   funct=aim->a;
  1157.   deref_ptr(funct);
  1158.   get_two_args(funct->attr_list,&arg1,&arg2);
  1159.   if (arg1 && arg2) {
  1160.     deref(arg1);
  1161.     deref(arg2);
  1162.     deref_args(funct,set_1_2);
  1163.     arg3=aim->b;
  1164.     deref(arg3);
  1165.  
  1166.     a1comp = matches(arg1->type,boolean,&sm1);
  1167.     a2comp = matches(arg2->type,boolean,&sm2);
  1168.     a3comp = matches(arg3->type,boolean,&sm3);
  1169.     if (a1comp && a2comp && a3comp) {
  1170.       a1 = get_bool(arg1->type);
  1171.       a2 = get_bool(arg2->type);
  1172.       a3 = get_bool(arg3->type);
  1173.       if ((a1==TRUE || a1==FALSE) && (a2==TRUE || a2==FALSE)) {
  1174.     unify_bool_result(arg3, a1^a2);
  1175.       } else if ((a1==TRUE || a1==FALSE) && (a3==TRUE || a3==FALSE)) {
  1176.     unify_bool_result(arg2, a1^a3);
  1177.       } else if ((a3==TRUE || a3==FALSE) && (a2==TRUE || a2==FALSE)) {
  1178.     unify_bool_result(arg1, a3^a2);
  1179.  
  1180.       } else if (a1==TRUE && arg3==arg2) {
  1181.     success=FALSE;
  1182.       } else if (a2==TRUE && arg3==arg2) {
  1183.     success=FALSE;
  1184.       } else if (a3==TRUE && arg1==arg2) {
  1185.     success=FALSE;
  1186.  
  1187.       } else if (a1==FALSE) {
  1188.     push_goal(unify,arg2,arg3,NULL);
  1189.       } else if (a2==FALSE) {
  1190.     push_goal(unify,arg1,arg3,NULL);
  1191.       } else if (a3==FALSE) {
  1192.     push_goal(unify,arg1,arg2,NULL);
  1193.  
  1194.       } else if (arg1==arg2) {
  1195.     unify_bool_result(arg3,FALSE);
  1196.       } else if (arg1==arg3) {
  1197.     unify_bool_result(arg2,FALSE);
  1198.       } else if (arg3==arg2) {
  1199.     unify_bool_result(arg1,FALSE);
  1200.       } else {
  1201.     if (a1==UNDEF) residuate(arg1);
  1202.     if (a2==UNDEF) residuate(arg2);
  1203.     if (a3==UNDEF) residuate(arg3);
  1204.       }
  1205.       if (!sm1) unify_bool(arg1);
  1206.       if (!sm2) unify_bool(arg2);
  1207.       if (!sm3) unify_bool(arg3);
  1208.     }
  1209.     else {
  1210.       success=FALSE;
  1211.       Errorline("Non-boolean argument or result in '%P'.\n",funct);
  1212.     }
  1213.   }
  1214.   else
  1215.     curry();
  1216.  
  1217.   return success;
  1218. }
  1219.  
  1220.  
  1221.  
  1222.  
  1223. /******** C_APPLY
  1224.   This evaluates "apply(functor => F,Args)".  If F is
  1225.   a known function, then it builds the psi-term F(Args), and evaluates it.
  1226. */
  1227. static long c_apply()
  1228. {
  1229.   long success=TRUE;
  1230.   ptr_psi_term funct,other;
  1231.   ptr_node n,fattr;
  1232.   
  1233.   funct=aim->a;
  1234.   deref_ptr(funct);
  1235.   n=find(featcmp,functor->keyword->symbol,funct->attr_list);
  1236.   if (n) {
  1237.     other=(ptr_psi_term )n->data;
  1238.     deref(other);
  1239.     if (other->type==top)
  1240.       residuate(other);
  1241.     else
  1242.       if(other->type && other->type->type!=function) {
  1243.     success=FALSE;
  1244.         Errorline("argument is not a function in %P.\n",funct);
  1245.       }
  1246.       else {
  1247.         /* What we really want here is to merge all attributes in       */
  1248.         /* funct->attr_list, except '*functor*', into other->attr_list. */
  1249.     clear_copy();
  1250.     other=distinct_copy(other);
  1251.         fattr=distinct_tree(funct->attr_list); /* Make distinct copy: PVR */
  1252.     push_goal(eval,other,aim->b,other->type->rule);
  1253.     merge_unify(&(other->attr_list),fattr);
  1254.         /* We don't want to remove anything from funct->attr_list here. */
  1255.     delete_attr(functor->keyword->symbol,&(other->attr_list));
  1256.       }
  1257.   }
  1258.   else
  1259.     curry();
  1260.   
  1261.   return success;
  1262. }
  1263.  
  1264.  
  1265.  
  1266. /******** C_PROJECT   /*  RM: Jan  7 1993 
  1267.   Here we evaluate "project(Psi-term,Label)". This
  1268.   returns the psi-term associated to label Label in Psi-term.
  1269.   It is identical to C_PROJECT except that the order of the arguments is
  1270.   inversed.
  1271. */
  1272. static long c_project()
  1273.  
  1274. {
  1275.   long success=TRUE;
  1276.   ptr_psi_term arg1,arg2,funct,result;
  1277.   ptr_node n;
  1278.   char *label;
  1279.   double v;
  1280.  
  1281.   /* char *thebuffer="integer"; 18.5 */
  1282.   char thebuffer[20]; /* Maximum number of digits in an integer */
  1283.   
  1284.   funct=aim->a;
  1285.   deref_ptr(funct);
  1286.   result=aim->b;
  1287.   get_two_args(funct->attr_list,&arg1,&arg2);
  1288.   if (arg2 && arg1) {
  1289.     deref(arg1);
  1290.     deref(arg2);
  1291.     deref_args(funct,set_1_2);
  1292.     
  1293.     label=NULL;
  1294.  
  1295.     /*  RM: Jul 20 1993: Don't residuate on 'string' etc...  */
  1296.     if(arg2->type!=top) {
  1297.       if(arg2->value && sub_type(arg2->type,quoted_string)) /* 10.8 */
  1298.     label=(char *)arg2->value;
  1299.       else
  1300.     if(arg2->value && sub_type(arg2->type,integer)) { /* 10.8 */
  1301.       v= *(REAL *)arg2->value;
  1302.       if(v==floor(v)) {
  1303.         sprintf(thebuffer,"%ld",(long)v);
  1304.         label=heap_copy_string(thebuffer); /* A little voracious */
  1305.       }
  1306.       else { /*  RM: Jul 28 1993  */
  1307.         Errorline("non-integer numeric feature in %P\n",funct);
  1308.         return FALSE;
  1309.       }
  1310.     }
  1311.     else {
  1312.       if(arg2->type->keyword->private_feature) /*  RM: Mar 12 1993  */
  1313.         label=arg2->type->keyword->combined_name;
  1314.       else
  1315.         label=arg2->type->keyword->symbol; 
  1316.     }
  1317.     }
  1318.     
  1319.     if (label) {
  1320.       n=find(featcmp,label,arg1->attr_list);
  1321.       
  1322.       if (n)
  1323.     push_goal(unify,result,n->data,NULL);
  1324.       else if (arg1->type->type==function && !(arg1->flags"ED_TRUE)) {
  1325.     Errorline("attempt to add a feature to curried function %P\n",
  1326.           arg1);
  1327.     return FALSE;
  1328.       }
  1329.       else {
  1330.     deref_ptr(result);
  1331.     if((GENERIC)arg1>=heap_pointer) { /*  RM: Feb  9 1993  */
  1332.       if((GENERIC)result<heap_pointer)
  1333.         push_psi_ptr_value(result,&(result->coref));
  1334.       clear_copy();
  1335.       result->coref=inc_heap_copy(result);
  1336.       heap_insert(featcmp,label,&(arg1->attr_list),result->coref);
  1337.     }
  1338.     else {
  1339.     
  1340. #ifdef ARITY  /*  RM: Mar 29 1993  */
  1341.       arity_add(arg1,label);
  1342. #endif
  1343.       
  1344.       /*  RM: Mar 25 1993  */
  1345.       if(arg1->type->always_check || arg1->attr_list)
  1346.         bk_stack_insert(featcmp,label,&(arg1->attr_list),result);
  1347.       else {
  1348.         bk_stack_insert(featcmp,label,&(arg1->attr_list),result);
  1349.         fetch_def_lazy(arg1, arg1->type,arg1->type,NULL,NULL);
  1350.       }
  1351.       
  1352.       if (arg1->resid)
  1353.         release_resid(arg1);
  1354.     }
  1355.       }    
  1356.     }
  1357.     else
  1358.       residuate(arg2);
  1359.   }
  1360.   else
  1361.     curry();
  1362.   
  1363.   return success;
  1364. }
  1365.  
  1366.  
  1367.  
  1368.  
  1369. /******** C_DIFF
  1370.   Arithmetic not-equal.
  1371. */
  1372. static long c_diff()
  1373. {
  1374.   long success=TRUE;
  1375.   ptr_psi_term arg1,arg2,arg3,t;
  1376.   long num1,num2,num3;
  1377.   REAL val1,val2,val3;
  1378.   
  1379.   t=aim->a;
  1380.   deref_ptr(t);
  1381.   get_two_args(t->attr_list,&arg1,&arg2);
  1382.   arg3=aim->b;
  1383.   
  1384.   if(arg1) {
  1385.     deref(arg1);
  1386.     success=get_real_value(arg1,&val1,&num1);
  1387.     if(success && arg2) {
  1388.       deref(arg2);
  1389.       deref_args(t,set_1_2);
  1390.       success=get_real_value(arg2,&val2,&num2);
  1391.     }
  1392.   }
  1393.   
  1394.   if(success)
  1395.     if(arg1 && arg2) {
  1396.       deref(arg3);
  1397.       success=get_bool_value(arg3,&val3,&num3);
  1398.       if(success)
  1399.     switch(num1+2*num2+4*num3) {
  1400.     case 0:
  1401.       if(arg1==arg2)
  1402.         unify_bool_result(arg3,FALSE);
  1403.       else
  1404.         residuate2(arg1,arg2);
  1405.       break;
  1406.     case 1:
  1407.       residuate2(arg2,arg3);
  1408.       break;
  1409.     case 2:
  1410.       residuate2(arg1,arg3);
  1411.       break;
  1412.     case 3:
  1413.       unify_bool_result(arg3,(val1!=val2));
  1414.       break;
  1415.     case 4:
  1416.       if(arg1==arg2 && val3)
  1417.         success=FALSE;
  1418.       else
  1419.         residuate2(arg1,arg2);
  1420.       break;
  1421.     case 5:
  1422.       if(val3)
  1423.         residuate(arg2);
  1424.       else
  1425.         success=unify_real_result(arg2,val1);
  1426.       break;
  1427.     case 6:
  1428.       if(val3)
  1429.         residuate(arg1);
  1430.       else
  1431.         success=unify_real_result(arg1,val2);
  1432.       break;
  1433.     case 7:
  1434.       success=(val3==(REAL)(val1!=val2));
  1435.       break;
  1436.     }
  1437.     }
  1438.     else
  1439.       curry();
  1440.   
  1441.   nonnum_warning(t,arg1,arg2);
  1442.   return success;
  1443. }
  1444.  
  1445.  
  1446.  
  1447.  
  1448. /******** C_FAIL
  1449.   Always fail.
  1450. */
  1451. static long c_fail()
  1452. {
  1453.   return FALSE;
  1454. }
  1455.  
  1456.  
  1457.  
  1458. /******** C_SUCCEED
  1459.   Always succeed.
  1460. */
  1461. static long c_succeed()
  1462. {
  1463.   ptr_psi_term t;
  1464.  
  1465.   t=aim->a;
  1466.   deref_args(t,set_empty);
  1467.   return TRUE;
  1468. }
  1469.  
  1470.  
  1471.  
  1472. /******** C_REPEAT
  1473.   Succeed indefinitely on backtracking.
  1474. */
  1475. static long c_repeat()
  1476. {
  1477.   ptr_psi_term t;
  1478.  
  1479.   t=aim->a;
  1480.   deref_args(t,set_empty);
  1481.   push_choice_point(prove,t,DEFRULES,NULL);
  1482.   return TRUE;
  1483. }
  1484.  
  1485.  
  1486. /******** C_VAR
  1487.   Return true/false iff argument is/is not '@' (top with no attributes).
  1488. */
  1489. static long c_var()
  1490. {
  1491.   long success=TRUE;
  1492.   ptr_psi_term arg1,result,g,other;
  1493.   
  1494.   g=aim->a;
  1495.   deref_ptr(g);
  1496.   result=aim->b;
  1497.   deref(result);
  1498.   get_one_arg(g->attr_list,&arg1);
  1499.   if (arg1) {
  1500.     deref(arg1);
  1501.     deref_args(g,set_1);
  1502.     other=stack_psi_term(4); /* 19.11 */
  1503.     other->type=((arg1->type==top)&&(arg1->attr_list==NULL))?true:false;
  1504.     resid_aim=NULL;
  1505.     push_goal(unify,result,other,NULL);
  1506.   }
  1507.   else {
  1508.     curry();
  1509.     /* Errorline("argument missing in %P.\n",t); */
  1510.     /* return c_abort(); */
  1511.   }
  1512.   
  1513.   return success;
  1514. }
  1515.  
  1516.  
  1517. /******** C_NONVAR
  1518.   Return true/false iff argument is not/is '@' (top with no attributes).
  1519. */
  1520. static long c_nonvar()
  1521. {
  1522.   long success=TRUE;
  1523.   ptr_psi_term arg1,result,g,other;
  1524.   
  1525.   g=aim->a;
  1526.   deref_ptr(g);
  1527.   result=aim->b;
  1528.   deref(result);
  1529.   get_one_arg(g->attr_list,&arg1);
  1530.   if (arg1) {
  1531.     deref(arg1);
  1532.     deref_args(g,set_1);
  1533.     other=stack_psi_term(4); /* 19.11 */
  1534.     other->type=((arg1->type==top)&&(arg1->attr_list==NULL))?false:true;
  1535.     resid_aim=NULL;
  1536.     push_goal(unify,result,other,NULL);
  1537.   }
  1538.   else {
  1539.     curry();
  1540.     /* Errorline("argument missing in %P.\n",t); */
  1541.     /* return c_abort(); */
  1542.   }
  1543.   
  1544.   return success;
  1545. }
  1546.  
  1547.  
  1548. /******** C_IS_FUNCTION
  1549.   Succeed iff argument is a function (built-in or user-defined).
  1550. */
  1551. static long c_is_function()
  1552. {
  1553.   long success=TRUE;
  1554.   ptr_psi_term arg1,result,g,other;
  1555.   
  1556.   g=aim->a;
  1557.   deref_ptr(g);
  1558.   result=aim->b;
  1559.   deref(result);
  1560.   get_one_arg(g->attr_list,&arg1);
  1561.   if (arg1) {
  1562.     deref(arg1);
  1563.     deref_args(g,set_1);
  1564.     other=stack_psi_term(4); /* 19.11 */
  1565.     other->type=(arg1->type->type==function)?true:false;
  1566.     resid_aim=NULL;
  1567.     push_goal(unify,result,other,NULL);
  1568.   }
  1569.   else {
  1570.     curry();
  1571.     /* Errorline("argument missing in %P.\n",t); */
  1572.     /* return c_abort(); */
  1573.   }
  1574.   
  1575.   return success;
  1576. }
  1577.  
  1578.  
  1579. /******** C_IS_PREDICATE
  1580.   Succeed iff argument is a predicate (built-in or user-defined).
  1581. */
  1582. static long c_is_predicate()
  1583. {
  1584.   long success=TRUE;
  1585.   ptr_psi_term arg1,result,g,other;
  1586.   
  1587.   g=aim->a;
  1588.   deref_ptr(g);
  1589.   result=aim->b;
  1590.   deref(result);
  1591.   get_one_arg(g->attr_list,&arg1);
  1592.   if (arg1) {
  1593.     deref(arg1);
  1594.     deref_args(g,set_1);
  1595.     other=stack_psi_term(4); /* 19.11 */
  1596.     other->type=(arg1->type->type==predicate)?true:false;
  1597.     resid_aim=NULL;
  1598.     push_goal(unify,result,other,NULL);
  1599.   }
  1600.   else {
  1601.     curry();
  1602.     /* Errorline("argument missing in %P.\n",t); */
  1603.     /* return c_abort(); */
  1604.   }
  1605.   
  1606.   return success;
  1607. }
  1608.  
  1609.  
  1610. /******** C_IS_SORT
  1611.   Succeed iff argument is a sort (built-in or user-defined).
  1612. */
  1613. static long c_is_sort()
  1614. {
  1615.   long success=TRUE;
  1616.   ptr_psi_term arg1,result,g,other;
  1617.   
  1618.   g=aim->a;
  1619.   deref_ptr(g);
  1620.   result=aim->b;
  1621.   deref(result);
  1622.   get_one_arg(g->attr_list,&arg1);
  1623.   if (arg1) {
  1624.     deref(arg1);
  1625.     deref_args(g,set_1);
  1626.     other=stack_psi_term(4); /* 19.11 */
  1627.     other->type=(arg1->type->type==type)?true:false;
  1628.     resid_aim=NULL;
  1629.     push_goal(unify,result,other,NULL);
  1630.   }
  1631.   else {
  1632.     curry();
  1633.     /* Errorline("argument missing in %P.\n",t); */
  1634.     /* return c_abort(); */
  1635.   }
  1636.   
  1637.   return success;
  1638. }
  1639.  
  1640.  
  1641.  
  1642. /* Return TRUE iff t has only argument "1", and return the argument. */
  1643. long only_arg1(t, arg1)
  1644. ptr_psi_term t;
  1645. ptr_psi_term *arg1;
  1646. {
  1647.   ptr_node n=t->attr_list;
  1648.  
  1649.   if (n && n->left==NULL && n->right==NULL && !featcmp(n->key,one)) {
  1650.     *arg1=(ptr_psi_term)n->data;
  1651.     return TRUE;
  1652.   }
  1653.   else
  1654.     return FALSE;
  1655. }
  1656.  
  1657.  
  1658.  
  1659. /******** C_DYNAMIC()
  1660.   Mark all the arguments as 'unprotected', i.e. they may be changed
  1661.   by assert/retract/redefinition.
  1662. */
  1663. static long c_dynamic()
  1664. {
  1665.   ptr_psi_term t=aim->a;
  1666.   deref_ptr(t);
  1667.   /* mark_quote(t); 14.9 */
  1668.   assert_protected(t->attr_list,FALSE);
  1669.   return TRUE;
  1670. }
  1671.  
  1672.  
  1673.  
  1674. /******** C_STATIC()
  1675.   Mark all the arguments as 'protected', i.e. they may not be changed
  1676.   by assert/retract/redefinition.
  1677. */
  1678. static long c_static()
  1679. {
  1680.   ptr_psi_term t=aim->a;
  1681.   deref_ptr(t);
  1682.   /* mark_quote(t); 14.9 */
  1683.   assert_protected(t->attr_list,TRUE);
  1684.   return TRUE;
  1685. }
  1686.  
  1687.  
  1688.  
  1689. /******** C_DELAY_CHECK()
  1690.   Mark that the properties of the types in the arguments are delay checked
  1691.   during unification (i.e. they are only checked when the psi-term is
  1692.   given attributes, and they are not checked as long as the psi-term has
  1693.   no attributes.)
  1694. */
  1695. static long c_delay_check()
  1696. {
  1697.   ptr_psi_term t=aim->a;
  1698.  
  1699.   deref_ptr(t);
  1700.   /* mark_quote(t); 14.9 */
  1701.   assert_delay_check(t->attr_list);
  1702.   inherit_always_check();
  1703.   return TRUE;
  1704. }
  1705.  
  1706.  
  1707.  
  1708. /******** C_NON_STRICT()
  1709.   Mark that the function or predicate's arguments are not evaluated when
  1710.   the function or predicate is called.
  1711. */
  1712. static long c_non_strict()
  1713. {
  1714.   ptr_psi_term t=aim->a;
  1715.  
  1716.   deref_ptr(t);
  1717.   /* mark_quote(t); 14.9 */
  1718.   assert_args_not_eval(t->attr_list);
  1719.   return TRUE;
  1720. }
  1721.  
  1722.  
  1723.  
  1724. /******** C_OP()
  1725.   Declare an operator.
  1726. */
  1727. static long c_op()
  1728. {
  1729.   long declare_operator();
  1730.   ptr_psi_term t=aim->a;
  1731.  
  1732.   return declare_operator(t);
  1733. }
  1734.  
  1735.  
  1736.  
  1737. long file_exists(s)
  1738. char *s;
  1739. {
  1740.   FILE *f;
  1741.   char *e;
  1742.   long success=FALSE;
  1743.   
  1744.   e=expand_file_name(s);
  1745.   if (f=fopen(e,"r")) {
  1746.     fclose(f);
  1747.     success=TRUE;
  1748.   }
  1749.   return success;
  1750. }
  1751.  
  1752.  
  1753.  
  1754. /******** C_EXISTS
  1755.   Succeed iff a file can be read in (i.e. if it exists).
  1756. */
  1757. static long c_exists()
  1758. {
  1759.   ptr_psi_term g;
  1760.   ptr_node n;
  1761.   long success=TRUE;
  1762.   ptr_psi_term arg1; 
  1763.   char *c_arg1; 
  1764.  
  1765.   g=aim->a;
  1766.   deref_ptr(g);
  1767.  
  1768.   if (success) {
  1769.     n=find(featcmp,one,g->attr_list);
  1770.     if (n) {
  1771.       arg1= (ptr_psi_term )n->data;
  1772.       deref(arg1);
  1773.       deref_args(g,set_1);
  1774.       if (!psi_to_string(arg1,&c_arg1)) {
  1775.         success=FALSE;
  1776.         Errorline("bad argument in %P.\n",g);
  1777.       }
  1778.     }
  1779.     else {
  1780.       success=FALSE;
  1781.       Errorline("bad argument in %P.\n",g);
  1782.     }
  1783.   }
  1784.  
  1785.   if (success)
  1786.     success=file_exists(c_arg1);
  1787.  
  1788.   return success;
  1789. }
  1790.  
  1791.  
  1792.  
  1793. /******** C_LOAD
  1794.   Load a file.  This load accepts and executes any queries in the loaded
  1795.   file, including calls to user-defined predicates and other load predicates.
  1796. */
  1797. static long c_load()
  1798. {
  1799.   long success=FALSE;
  1800.   ptr_psi_term arg1,arg2,t;
  1801.   char *fn;
  1802.  
  1803.   t=aim->a;
  1804.   deref_ptr(t);
  1805.   get_two_args(t->attr_list,&arg1,&arg2);
  1806.   if(arg1) {
  1807.     deref(arg1);
  1808.     deref_args(t,set_1);
  1809.     if (psi_to_string(arg1,&fn)) {
  1810.       success=open_input_file(fn);
  1811.       if (success) {
  1812.     file_date+=2;
  1813.     push_goal(load,input_state,file_date,fn);
  1814.     file_date+=2;
  1815.       }
  1816.     }
  1817.     else {
  1818.       Errorline("bad file name in %P.\n",t);
  1819.       success=FALSE;
  1820.     }
  1821.   }
  1822.   else {
  1823.     Errorline("no file name in %P.\n",t);
  1824.     success=FALSE;
  1825.   }
  1826.  
  1827.   return success;
  1828. }
  1829.  
  1830.  
  1831.  
  1832. /******** C_GET_CHOICE()
  1833.   Return the current state of the choice point stack (i.e., the time stamp
  1834.   of the current choice point).
  1835. */
  1836. static long c_get_choice()
  1837. {
  1838.   long gts,success=TRUE;
  1839.   ptr_psi_term funct,result;
  1840.  
  1841.   funct=aim->a;
  1842.   deref_ptr(funct);
  1843.   result=aim->b;
  1844.   deref_args(funct,set_empty);
  1845.   if (choice_stack)
  1846.     gts=choice_stack->time_stamp;
  1847.   else
  1848.     gts=global_time_stamp-1;
  1849.     /* gts=INIT_TIME_STAMP; PVR 11.2.94 */
  1850.   push_goal(unify,result,real_stack_psi_term(4,(REAL)gts),NULL);
  1851.  
  1852.   return success;
  1853. }
  1854.  
  1855.  
  1856.  
  1857. /******** C_SET_CHOICE()
  1858.   Set the choice point stack to a state no later than (i.e. the same or earlier
  1859.   than) the state of the first argument (i.e., remove all choice points up to
  1860.   the first one whose time stamp is =< the first argument).  This predicate
  1861.   will remove zero or more choice points, never add them.  The first argument
  1862.   must come from a past call to get_choice.
  1863.   Together, get_choice and set_choice allow one to implement an "ancestor cut"
  1864.   that removes all choice points created between the current execution point
  1865.   and an execution point arbitarily remote in the past.
  1866.   The built-ins get_choice, set_choice, and exists_choice are implemented
  1867.   using the timestamping mechanism in the interpreter.  The two
  1868.   relevant properties of the timestamping mechanism are that each choice
  1869.   point is identified by an integer and that the integers are in increasing
  1870.   order (but not necessarily consecutive) from the bottom to the top of the
  1871.   choice point stack.
  1872. */
  1873. static long c_set_choice()
  1874. {
  1875.   REAL gts_r;
  1876.   long gts;
  1877.   long num,success=TRUE;
  1878.   ptr_psi_term t,arg1;
  1879.   ptr_choice_point cutpt;
  1880.  
  1881.   t=aim->a;
  1882.   deref_ptr(t);
  1883.   get_one_arg(t->attr_list,&arg1);
  1884.   if (arg1) {
  1885.     deref(arg1);
  1886.     deref_args(t,set_1);
  1887.     success = get_real_value(arg1,>s_r,&num);
  1888.     if (success) {
  1889.       if (num) {
  1890.         gts=(unsigned long)gts_r;
  1891.         if (choice_stack) {
  1892.           cutpt=choice_stack;
  1893.           while (cutpt && cutpt->time_stamp>gts) cutpt=cutpt->next;
  1894.           if (choice_stack!=cutpt) {
  1895.             choice_stack=cutpt;
  1896. #ifdef CLEAN_TRAIL
  1897.             clean_trail(choice_stack);
  1898. #endif
  1899.           }
  1900.         }
  1901.       }
  1902.       else {
  1903.         Errorline("bad argument to %P.\n",t);
  1904.     success=FALSE;
  1905.       }
  1906.     }
  1907.     else {
  1908.       Errorline("bad argument %P.\n",t);
  1909.       success=FALSE;
  1910.     }
  1911.   }
  1912.   else
  1913.     curry();
  1914.  
  1915.   return success;
  1916. }
  1917.  
  1918.  
  1919.  
  1920. /******** C_EXISTS_CHOICE()
  1921.   Return true iff there exists a choice point A such that arg1 < A <= arg2,
  1922.   i.e. A is more recent than the choice point marked by arg1 and no more
  1923.   recent than the choice point marked by arg2.  The two arguments to
  1924.   exists_choice must come from past calls to get_choice.
  1925.   This function allows one to check whether a choice point exists between
  1926.   any two arbitrary execution points of the program.
  1927. */
  1928. static long c_exists_choice()
  1929. {
  1930.   REAL gts_r;
  1931.   long ans,gts1,gts2,num,success=TRUE;
  1932.   ptr_psi_term funct,result,arg1,arg2,ans_term;
  1933.   ptr_choice_point cp;
  1934.  
  1935.   funct=aim->a;
  1936.   deref_ptr(funct);
  1937.   result=aim->b;
  1938.   deref_args(funct,set_empty);
  1939.   get_two_args(funct->attr_list,&arg1,&arg2);
  1940.   if (arg1 && arg2) {
  1941.     deref(arg1);
  1942.     deref(arg2);
  1943.     deref_args(funct,set_1_2);
  1944.     success = get_real_value(arg1,>s_r,&num);
  1945.     if (success && num) {
  1946.       gts1 = (unsigned long) gts_r;
  1947.       success = get_real_value(arg2,>s_r,&num);
  1948.       if (success && num) {
  1949.         gts2 = (unsigned long) gts_r;
  1950.         cp = choice_stack;
  1951.         if (cp) {
  1952.           while (cp && cp->time_stamp>gts2) cp=cp->next;
  1953.           ans=(cp && cp->time_stamp>gts1);
  1954.         }
  1955.         else
  1956.           ans=FALSE;
  1957.         ans_term=stack_psi_term(4);
  1958.         ans_term->type=ans?true:false;
  1959.         push_goal(unify,result,ans_term,NULL);
  1960.       }
  1961.       else {
  1962.         Errorline("bad second argument to %P.\n",funct);
  1963.         success=FALSE;
  1964.       }
  1965.     }
  1966.     else {
  1967.       Errorline("bad first argument %P.\n",funct);
  1968.       success=FALSE;
  1969.     }
  1970.   }
  1971.   else
  1972.     curry();
  1973.  
  1974.   return success;
  1975. }
  1976.  
  1977.  
  1978.  
  1979. /******** C_PRINT_VARIABLES
  1980.   Print the global variables and their values,
  1981.   in the same way as is done in the user interface.
  1982. */
  1983. static long c_print_variables()
  1984. {
  1985.   long success=TRUE;
  1986.  
  1987.   print_variables(TRUE); /* 21.1 */
  1988.  
  1989.   return success;
  1990. }
  1991.  
  1992.  
  1993.  
  1994. static void set_parse_queryflag(thelist, sort)
  1995. ptr_node thelist;
  1996. long sort;
  1997. {
  1998.   ptr_node n;             /* node pointing to argument 2  */
  1999.   ptr_psi_term arg;       /* argumenrt 2 psi-term */
  2000.   ptr_psi_term queryflag; /* query term created by this function */
  2001.  
  2002.   n=find(featcmp,two,thelist);
  2003.   if (n) {
  2004.     /* there was a second argument */
  2005.     arg=(ptr_psi_term)n->data;
  2006.     queryflag=stack_psi_term(4);
  2007.     queryflag->type =
  2008.     update_symbol(bi_module,
  2009.           ((sort==QUERY)?"query":
  2010.                   ((sort==FACT)?"declaration":"error")));
  2011.     push_goal(unify,queryflag,arg,NULL);
  2012.   }
  2013. }
  2014.  
  2015.  
  2016. /******** C_PARSE
  2017.   Parse a string and return a quoted psi-term.
  2018.   The global variable names are recognized (see the built-in
  2019.   print_variables).  All variables in the parsed string
  2020.   are added to the set of global variables.
  2021. */
  2022. static long c_parse()
  2023. {
  2024.   long success=TRUE;
  2025.   ptr_psi_term arg1,arg2,arg3,funct,result;
  2026.   long smaller,sort,old_var_occurred;
  2027.   ptr_node n;
  2028.   parse_block pb;
  2029.  
  2030.   funct=aim->a;
  2031.   deref_ptr(funct);
  2032.   result=aim->b;
  2033.   get_one_arg(funct->attr_list,&arg1);
  2034.   if (arg1) {
  2035.     deref(arg1);
  2036.     deref_args(funct,set_1);
  2037.     success=matches(arg1->type,quoted_string,&smaller);
  2038.     if (success) {
  2039.       if (arg1->value) {
  2040.         ptr_psi_term t;
  2041.  
  2042.         /* Parse the string in its own state */
  2043.         save_parse_state(&pb);
  2044.         init_parse_state();
  2045.         stringparse=TRUE;
  2046.         stringinput=(char*)arg1->value;
  2047.  
  2048.         old_var_occurred=var_occurred;
  2049.         var_occurred=FALSE;
  2050.         t=stack_copy_psi_term(parse(&sort));
  2051.         
  2052.           /* Optional second argument returns 'query', 'declaration', or
  2053.           /* 'error'. */
  2054.           n=find(featcmp,two,funct->attr_list);
  2055.          if (n) {
  2056.             ptr_psi_term queryflag;
  2057.             arg2=(ptr_psi_term)n->data;
  2058.             queryflag=stack_psi_term(4);
  2059.             queryflag->type=
  2060.               update_symbol(bi_module,
  2061.                 ((sort==QUERY)?"query":((sort==FACT)?"declaration":"error"))
  2062.               );
  2063.             push_goal(unify,queryflag,arg2,NULL);
  2064.           }
  2065.   
  2066.           /* Optional third argument returns true or false if the psi-term
  2067.           /* contains a variable or not. */
  2068.           n=find(featcmp,three,funct->attr_list);
  2069.           if (n) {
  2070.             ptr_psi_term varflag;
  2071.             arg3=(ptr_psi_term)n->data;
  2072.             varflag=stack_psi_term(4);
  2073.             varflag->type=var_occurred?true:false;
  2074.             push_goal(unify,varflag,arg3,NULL);
  2075.           }
  2076.  
  2077.         var_occurred = var_occurred || old_var_occurred;
  2078.         stringparse=FALSE;
  2079.         restore_parse_state(&pb);
  2080.  
  2081.         /* parse_ok flag says whether there was a syntax error. */
  2082.         if (TRUE /*parse_ok*/) {
  2083.           mark_quote(t);
  2084.           push_goal(unify,t,result,NULL);
  2085.         }
  2086.         else
  2087.           success=FALSE;
  2088.       }
  2089.       else
  2090.         residuate(arg1);
  2091.     }
  2092.     else
  2093.       success=FALSE;
  2094.   }
  2095.   else
  2096.    curry();
  2097.  
  2098.   return success;
  2099. }
  2100.  
  2101.  
  2102.  
  2103.  
  2104.  
  2105. /******** C_READ
  2106.   Read a psi_term or a token from the current input stream.
  2107.   The variables in the object read are not added to the set
  2108.   of global variables.
  2109. */
  2110.  
  2111. static long c_read();
  2112.      
  2113. static long c_read_psi() { return (c_read(TRUE)); }
  2114.  
  2115. static long c_read_token() { return (c_read(FALSE)); }
  2116.  
  2117. static long c_read(psi_flag)     
  2118. long psi_flag;
  2119. {
  2120.   long success=TRUE;
  2121.   long sort;
  2122.   ptr_psi_term arg1,arg2,arg3,g,t;
  2123.   ptr_node old_var_tree;
  2124.   ptr_node n;
  2125.   int line=line_count+1;
  2126.   
  2127.   g=aim->a;
  2128.   deref_ptr(g);
  2129.   get_one_arg(g->attr_list,&arg1);
  2130.   if (arg1) {
  2131.     deref_args(g,set_1);
  2132.     if (eof_flag) {
  2133.       Errorline("attempt to read past end of file (%E).\n");
  2134.       return (abort_life(TRUE));
  2135.     }
  2136.     else {
  2137.       prompt="";
  2138.       old_var_tree=var_tree;
  2139.       var_tree=NULL;
  2140.       if (psi_flag) {
  2141.         t=stack_copy_psi_term(parse(&sort));
  2142.  
  2143.  
  2144.     /* Optional second argument returns 'query', 'declaration', or
  2145.        'error'. */
  2146.     n=find(featcmp,two,g->attr_list); /*  RM: Jun  8 1993  */
  2147.     if (n) {
  2148.       ptr_psi_term queryflag;
  2149.       arg2=(ptr_psi_term)n->data;
  2150.       queryflag=stack_psi_term(4);
  2151.       queryflag->type=
  2152.         update_symbol(bi_module,
  2153.               ((sort==QUERY)?"query":((sort==FACT)?"declaration":"error"))
  2154.               );
  2155.       push_goal(unify,queryflag,arg2,NULL);
  2156.     }
  2157.  
  2158.  
  2159.     /* Optional third argument returns the starting line number */
  2160.     /*  RM: Oct 11 1993  */
  2161.     n=find(featcmp,three,g->attr_list);
  2162.     if (n) {
  2163.       arg3=(ptr_psi_term)n->data;
  2164.       g=stack_psi_term(4);
  2165.       g->type=integer;
  2166.       g->value=heap_alloc(sizeof(REAL));
  2167.       *(REAL *)g->value=line;
  2168.       push_goal(unify,g,arg3,NULL);
  2169.     }
  2170.     
  2171.       }
  2172.       else {
  2173.         t=stack_psi_term(0);
  2174.         read_token_b(t);
  2175.     /*  RM: Jan  5 1993  removed spurious argument: " (??) */
  2176.     
  2177.       }
  2178.       if (t->type==eof) eof_flag=TRUE;
  2179.       var_tree=old_var_tree;
  2180.     }
  2181.     
  2182.     if (success) {
  2183.       mark_quote(t);
  2184.       push_goal(unify,t,arg1,NULL);
  2185.       /* i_check_out(t); */
  2186.     }
  2187.   }
  2188.   else {
  2189.     Errorline("argument missing in %P.\n",g);
  2190.     success=FALSE;
  2191.   }
  2192.   
  2193.   return success;
  2194. }
  2195.  
  2196.  
  2197.  
  2198. /******** C_HALT
  2199.   Exit the Wild_Life interpreter.
  2200. */
  2201. int c_halt()   /*  RM: Jan  8 1993  Used to be 'void' */
  2202. {
  2203.   exit_life(TRUE);
  2204. }
  2205.  
  2206.  
  2207. void exit_life(nl_flag)
  2208. long nl_flag;
  2209. {
  2210.   open_input_file("stdin");
  2211.   times(&life_end);
  2212.   if (NOTQUIET) { /* 21.1 */
  2213.     if (nl_flag) printf("\n");
  2214.     printf("*** Exiting Wild_Life  ");
  2215. #ifndef OS2_PORT
  2216.     printf("[%1.3fs cpu, %1.3fs gc (%2.1f%%)]\n",
  2217.            (life_end.tms_utime-life_start.tms_utime)/60.0,
  2218.            garbage_time,
  2219.            garbage_time*100 / ((life_end.tms_utime-life_start.tms_utime)/60.0)
  2220.        );
  2221. #else
  2222.     printf("[%1.3fs cpu, %1.3fs gc (%2.1f%%)]\n",
  2223.            (life_end-life_start)/60.0,
  2224.            garbage_time,
  2225.            garbage_time*100 / ((life_end-life_start)/60.0)
  2226.        );
  2227. #endif
  2228.   }
  2229.  
  2230. #ifdef ARITY  /*  RM: Mar 29 1993  */
  2231.   arity_end();
  2232. #endif
  2233.   
  2234.   exit(1);
  2235. }
  2236.  
  2237.  
  2238.  
  2239. /******** C_ABORT
  2240.   Return to the top level of the interpreter.
  2241. */
  2242. long c_abort()   /*  RM: Feb 15 1993  */
  2243. {
  2244.   return (abort_life(TRUE));
  2245. }
  2246.  
  2247.  
  2248. /* 26.1 */
  2249. long abort_life(nlflag) /*  RM: Feb 15 1993  */
  2250. int nlflag;
  2251. {
  2252.   if ( aborthooksym->type!=function ||
  2253.        !aborthooksym->rule->b ||
  2254.        aborthooksym->rule->b->type==abortsym) {
  2255.     /* Do a true abort if aborthook is not a function or is equal to 'abort'.*/
  2256.     main_loop_ok = FALSE;
  2257.     undo(NULL); /* 8.10 */
  2258.     if(NOTQUIET) fprintf(stderr,"\n*** Abort"); /*  RM: Feb 17 1993  */
  2259.     if(NOTQUIET && nlflag) fprintf(stderr,"\n");/*  RM: Feb 17 1993  */
  2260.   } else {
  2261.     /* Do a 'user-defined abort': initialize the system, then */
  2262.     /* prove the user-defined abort routine (which is set by  */
  2263.     /* means of 'setq(aborthook,user_defined_abort)'.         */
  2264.     ptr_psi_term aborthook;
  2265.  
  2266.     undo(NULL);
  2267.     init_system();
  2268.     var_occurred=FALSE;
  2269.     stdin_cleareof();
  2270.     if(NOTQUIET) fprintf(stderr,"\n*** Abort"); /*  RM: Feb 17 1993  */
  2271.     if(NOTQUIET && nlflag) fprintf(stderr,"\n");/*  RM: Feb 17 1993  */
  2272.     aborthook=stack_psi_term(0);
  2273.     aborthook->type=aborthooksym;
  2274.     push_goal(prove,aborthook,DEFRULES,NULL);
  2275.   }
  2276.   return TRUE;
  2277. }
  2278.  
  2279.  
  2280.  
  2281. /******** C_NOT_IMPLEMENTED
  2282.   This function always fails, it is in fact identical to BOTTOM.
  2283. */
  2284. static long c_not_implemented()
  2285. {
  2286.   ptr_psi_term t;
  2287.   
  2288.   t=aim->a;
  2289.   deref_ptr(t);
  2290.   Errorline("built-in %P is not implemented yet.\n",t);
  2291.   return FALSE;
  2292. }
  2293.  
  2294.  
  2295.  
  2296. /******** C_DECLARATION
  2297.   This function always fails, it is in fact identical to BOTTOM.
  2298. */
  2299. static long c_declaration()
  2300. {
  2301.   ptr_psi_term t;
  2302.   
  2303.   t=aim->a;
  2304.   deref_ptr(t);
  2305.   Errorline("%P is a declaration, not a query.\n",t);
  2306.   return FALSE;
  2307. }
  2308.  
  2309.  
  2310.  
  2311. /******** C_SETQ
  2312.  
  2313.   Create a function with one rule F -> X, where F and X are the
  2314.   arguments of setq.  Setq evaluates its first argument and quotes the first.
  2315.   away any previous definition of F.  F must be undefined or a function, there
  2316.   is an error if F is a sort or a predicate.  This gives an error for a static
  2317.   function, but none for an undefined (i.e. uninterpreted) psi-term, which is
  2318.   made dynamic.  */
  2319.  
  2320.  
  2321. static long c_setq()
  2322. {
  2323.   long success=FALSE;
  2324.   ptr_psi_term arg1,arg2,g;
  2325.   ptr_pair_list p;
  2326.   ptr_definition d;
  2327.  
  2328.   g=aim->a;
  2329.   get_two_args(g->attr_list,&arg1,&arg2);
  2330.   if (arg1 && arg2) {
  2331.     deref_rec(arg2); /*  RM: Jan  6 1993  */
  2332.     deref_ptr(arg1);
  2333.     d=arg1->type;
  2334.     if (d->type==function || d->type==undef) {
  2335.       if (d->type==undef || !d->protected) {
  2336.         if (!arg1->attr_list) {
  2337.           d->type=function;
  2338.           d->protected=FALSE;
  2339.           p=HEAP_ALLOC(pair_list);
  2340.           p->a=heap_psi_term(4);
  2341.           p->a->type=d;
  2342.           clear_copy();
  2343.           p->b=quote_copy(arg2,HEAP);
  2344.           p->next=NULL;
  2345.           d->rule=p;
  2346.           success=TRUE;
  2347.         }
  2348.         else
  2349.          Errorline("%P may not have arguments in %P.\n",arg1,g);
  2350.       }
  2351.       else
  2352.         Errorline("%P should be dynamic in %P.\n",arg1,g);
  2353.     }
  2354.     else
  2355.       Errorline("%P should be a function or uninterpreted in %P.\n",arg1,g);
  2356.   }
  2357.   else
  2358.     Errorline("%P is missing one or both arguments.\n",g);
  2359.  
  2360.   return success;
  2361. }
  2362.  
  2363.  
  2364.  
  2365. /******** C_ASSERT_FIRST
  2366.   Assert a fact, inserting it as the first clause
  2367.   for that predicate or function.
  2368. */
  2369. static long c_assert_first()
  2370. {
  2371.   long success=FALSE;
  2372.   ptr_psi_term arg1,g;
  2373.   
  2374.   g=aim->a;
  2375.   bk_mark_quote(g); /*  RM: Apr  7 1993  */
  2376.   get_one_arg(g->attr_list,&arg1);
  2377.   assert_first=TRUE;
  2378.   if (arg1) {
  2379.     deref_ptr(arg1);
  2380.     assert_clause(arg1);
  2381.     encode_types();
  2382.     success=assert_ok;
  2383.   }
  2384.   else {
  2385.     success=FALSE;
  2386.     Errorline("bad clause in %P.\n",g);
  2387.   }
  2388.   
  2389.   return success;
  2390. }
  2391.  
  2392.  
  2393.  
  2394. /******** C_ASSERT_LAST
  2395.   Assert a fact, inserting as the last clause for that predicate or function.
  2396. */
  2397. static long c_assert_last()
  2398. {
  2399.   long success=FALSE;
  2400.   ptr_psi_term arg1,g;
  2401.   
  2402.   g=aim->a;
  2403.   bk_mark_quote(g); /*  RM: Apr  7 1993  */
  2404.   get_one_arg(g->attr_list,&arg1);
  2405.   assert_first=FALSE;
  2406.   if (arg1) {
  2407.     deref_ptr(arg1);
  2408.     assert_clause(arg1);
  2409.     encode_types();
  2410.     success=assert_ok;
  2411.   }
  2412.   else {
  2413.     success=FALSE;
  2414.     Errorline("bad clause in %P.\n",g);
  2415.   }
  2416.   
  2417.   return success;
  2418. }
  2419.  
  2420.  
  2421.  
  2422. /******** PRED_CLAUSE(t,r,g)
  2423.   Set about finding a clause that unifies with psi_term T.
  2424.   This routine is used both for CLAUSE and RETRACT.
  2425.   If R==TRUE then delete the first clause which unifies with T.
  2426. */
  2427. long pred_clause(t,r,g)
  2428. ptr_psi_term t, g;
  2429. long r;
  2430. {
  2431.   long success=FALSE;
  2432.   ptr_psi_term head,body;
  2433.   
  2434.   bk_mark_quote(g); /*  RM: Apr  7 1993  */
  2435.   if (t) {
  2436.     deref_ptr(t);
  2437.     
  2438.     if (!strcmp(t->type->keyword->symbol,"->")) {
  2439.       get_two_args(t->attr_list,&head,&body);
  2440.       if (head) {
  2441.     deref_ptr(head);
  2442.     if (head && body &&
  2443.             (head->type->type==function || head->type->type==undef))
  2444.       success=TRUE;
  2445.       }
  2446.     }
  2447.     else if (!strcmp(t->type->keyword->symbol,":-")) {
  2448.       get_two_args(t->attr_list,&head,&body);
  2449.       if (head) {
  2450.         deref_ptr(head);
  2451.         if (head &&
  2452.             (head->type->type==predicate || head->type->type==undef)) {
  2453.           success=TRUE;
  2454.           if (!body) {
  2455.             body=stack_psi_term(4);
  2456.             body->type=succeed;
  2457.           }
  2458.         }
  2459.       }
  2460.     }
  2461.     /* There is no body, so t is a fact */
  2462.     else if (t->type->type==predicate || t->type->type==undef) {
  2463.       head=t;
  2464.       body=stack_psi_term(4);
  2465.       body->type=succeed;
  2466.       success=TRUE;
  2467.     }
  2468.   }
  2469.   
  2470.   if (success) {
  2471.     if (r) {
  2472.       if (redefine(head))
  2473.         push_goal(del_clause,head,body,&(head->type->rule));
  2474.       else
  2475.         success=FALSE;
  2476.     }
  2477.     else
  2478.       push_goal(clause,head,body,&(head->type->rule));
  2479.   }
  2480.   else
  2481.     Errorline("bad argument in %s.\n", (r?"retract":"clause"));
  2482.   
  2483.   return success;
  2484. }
  2485.  
  2486.  
  2487.  
  2488. /******** C_CLAUSE
  2489.   Find the clauses that unify with the argument in the rules.
  2490.   The argument must be a predicate or a function.
  2491.   Use PRED_CLAUSE to perform the search.
  2492. */
  2493. static long c_clause()
  2494. {
  2495.   long success=FALSE;
  2496.   ptr_psi_term arg1,arg2,g;
  2497.   
  2498.   g=aim->a;
  2499.   get_two_args(g->attr_list,&arg1,&arg2);
  2500.   success=pred_clause(arg1,0,g);
  2501.   return success;
  2502. }
  2503.  
  2504.  
  2505.  
  2506. /******** C_RETRACT
  2507.   Retract the first clause that unifies with the argument.
  2508.   Use PRED_CLAUSE to perform the search.
  2509. */
  2510. static long c_retract()
  2511. {
  2512.   long success=FALSE;
  2513.   ptr_psi_term arg1,arg2,g;
  2514.   
  2515.   g=aim->a;
  2516.   get_two_args(g->attr_list,&arg1,&arg2);
  2517.   success=pred_clause(arg1,1,g);
  2518.   
  2519.   return success;
  2520. }
  2521.  
  2522.  
  2523. void global_error_check();
  2524. void global_tree();
  2525. void global_one();
  2526.  
  2527. /******** C_GLOBAL
  2528.   Declare that a symbol is a global variable.
  2529.   Handle multiple arguments and initialization
  2530.   (the initialization term is evaluated).
  2531.   If there is an error anywhere in the declaration,
  2532.   then evaluate and declare nothing.
  2533. */
  2534. static long c_global()    /*  RM: Feb 10 1993  */
  2535. {
  2536.   long error=FALSE, eval=FALSE;
  2537.   ptr_psi_term g;
  2538.   
  2539.   g=aim->a;
  2540.   deref_ptr(g);
  2541.   if (g->attr_list) {
  2542.     /* Do error check of all arguments first: */
  2543.     global_error_check(g->attr_list, &error, &eval);
  2544.     if (eval) return !error;
  2545.     /* If no errors, then make the arguments global: */
  2546.     if (!error)
  2547.       global_tree(g->attr_list);
  2548.   } else {
  2549.     Errorline("argument(s) missing in %P\n",g);
  2550.   }
  2551.   
  2552.   return !error;
  2553. }
  2554.  
  2555.  
  2556.  
  2557. void global_error_check(n, error, eval)
  2558. ptr_node n;
  2559. int *error, *eval;
  2560. {
  2561.   if (n) {
  2562.     ptr_psi_term t,a1,a2;
  2563.     int bad_init=FALSE;
  2564.     global_error_check(n->left, error, eval);
  2565.  
  2566.     t=(ptr_psi_term)n->data;
  2567.     deref_ptr(t);
  2568.     if (t->type==leftarrowsym) {
  2569.       get_two_args(t->attr_list,&a1,&a2);
  2570.       if (a1==NULL || a2==NULL) {
  2571.         Errorline("%P is an incorrect global variable declaration (%E).\n",t);
  2572.     *error=TRUE;
  2573.     bad_init=TRUE;
  2574.       } else {
  2575.     deref_ptr(a1);
  2576.     deref_ptr(a2);
  2577.     t=a1;
  2578.         if (deref_eval(a2)) *eval=TRUE;
  2579.       }
  2580.     }
  2581.     if (!bad_init && t->type->type!=undef && t->type->type!=global) {
  2582.       Errorline("%T %P cannot be redeclared as a global variable (%E).\n",
  2583.         t->type->type,
  2584.         t);
  2585.       t->type=error_psi_term->type;
  2586.       t->value=NULL; /*  RM: Mar 23 1993  */
  2587.       *error=TRUE;
  2588.     }
  2589.  
  2590.     global_error_check(n->right, error, eval);
  2591.   }
  2592. }
  2593.  
  2594.  
  2595. void global_tree(n)
  2596. ptr_node n;
  2597. {
  2598.   if (n) {
  2599.     ptr_psi_term t;
  2600.     global_tree(n->left);
  2601.  
  2602.     t=(ptr_psi_term)n->data;
  2603.     deref_ptr(t);
  2604.     global_one(t);
  2605.  
  2606.     global_tree(n->right);
  2607.   }
  2608. }
  2609.  
  2610.  
  2611. void global_one(t)
  2612. ptr_psi_term t;
  2613. {
  2614.   ptr_psi_term u,val;
  2615.  
  2616.   if (t->type==leftarrowsym) {
  2617.     get_two_args(t->attr_list,&t,&u);
  2618.     deref_ptr(t);
  2619.     deref_ptr(u);
  2620.   }
  2621.   else
  2622.     u=stack_psi_term(4);
  2623.   
  2624.   clear_copy();
  2625.   t->type->type=global;
  2626.   t->type->init_value=quote_copy(u,HEAP); /*  RM: Mar 23 1993  */
  2627.  
  2628.   /* eval_global_var(t);   RM: Feb  4 1994  */
  2629.   
  2630.   /*  RM: Nov 10 1993 
  2631.       val=t->type->global_value;
  2632.       if (val && (GENERIC)val<heap_pointer) {
  2633.       deref_ptr(val);
  2634.       push_psi_ptr_value(val,&(val->coref));
  2635.       val->coref=u;
  2636.       } else
  2637.       t->type->global_value=u;
  2638.   */
  2639. }
  2640.  
  2641.  
  2642.  
  2643. /******** C_PERSISTENT
  2644.   Declare that a symbol is a persistent variable.
  2645. */
  2646. static long c_persistent()     /*  RM: Feb 10 1993  */
  2647. {
  2648.   long error=FALSE;
  2649.   ptr_psi_term g;
  2650.  
  2651.   g=aim->a;
  2652.   deref_ptr(g);
  2653.   if (g->attr_list) {
  2654.     /* Do error check of all arguments first: */
  2655.     persistent_error_check(g->attr_list, &error);
  2656.     /* If no errors, then make the arguments persistent: */
  2657.     if (!error)
  2658.       persistent_tree(g->attr_list);
  2659.   } else {
  2660.     Errorline("argument(s) missing in %P\n",g);
  2661.   }
  2662.  
  2663.   return !error;
  2664. }
  2665.  
  2666.  
  2667. persistent_error_check(n, error)
  2668. ptr_node n;
  2669. int *error;
  2670. {
  2671.   if (n) {
  2672.     ptr_psi_term t;
  2673.     persistent_error_check(n->left, error);
  2674.  
  2675.     t=(ptr_psi_term)n->data;
  2676.     deref_ptr(t);
  2677.     if (t->type->type!=undef && t->type->type!=global) {
  2678.       Errorline("%T %P cannot be redeclared persistent (%E).\n",
  2679.              t->type->type,
  2680.              t);
  2681.       t->type=error_psi_term->type;
  2682.       *error=TRUE;
  2683.     }
  2684.  
  2685.     persistent_error_check(n->right, error);
  2686.   }
  2687. }
  2688.  
  2689.  
  2690. persistent_tree(n)
  2691. ptr_node n;
  2692. {
  2693.   if (n) {
  2694.     ptr_psi_term t;
  2695.     persistent_tree(n->left);
  2696.  
  2697.     t=(ptr_psi_term)n->data;
  2698.     deref_ptr(t);
  2699.     persistent_one(t);
  2700.  
  2701.     persistent_tree(n->right);
  2702.   }
  2703. }
  2704.  
  2705.  
  2706. persistent_one(t)
  2707. ptr_psi_term t;
  2708. {
  2709.   t->type->type=global;
  2710.   if ((GENERIC)t->type->global_value<(GENERIC)heap_pointer)
  2711.     t->type->global_value=heap_psi_term(4);
  2712. }
  2713.  
  2714.  
  2715.  
  2716. /******** C_OPEN_IN
  2717.   Create a stream for input from the specified file.
  2718. */
  2719. static long c_open_in()
  2720. {
  2721.   long success=FALSE;
  2722.   ptr_psi_term arg1,arg2,g;
  2723.   char *fn;
  2724.   
  2725.   g=aim->a;
  2726.   deref_ptr(g);
  2727.   get_two_args(g->attr_list,&arg1,&arg2);
  2728.   if(arg1) {
  2729.     deref(arg1);
  2730.     if (psi_to_string(arg1,&fn))
  2731.       if (arg2) {
  2732.     deref(arg2);
  2733.         deref_args(g,set_1_2);
  2734.     if (is_top(arg2)) {
  2735.       if (open_input_file(fn)) {
  2736.         /* push_ptr_value(psi_term_ptr,&(arg2->coref)); 9.6 */
  2737.         push_psi_ptr_value(arg2,&(arg2->coref));
  2738.         arg2->coref=input_state;
  2739.         success=TRUE;
  2740.       }
  2741.       else
  2742.         success=FALSE;
  2743.         }
  2744.     else
  2745.       Errorline("bad input stream in %P.\n",g);
  2746.       }
  2747.       else
  2748.     Errorline("no stream in %P.\n",g);
  2749.     else
  2750.       Errorline("bad file name in %P.\n",g);
  2751.   }
  2752.   else
  2753.     Errorline("no file name in %P.\n",g);
  2754.  
  2755.   return success;
  2756. }
  2757.  
  2758.  
  2759.  
  2760. /******** C_OPEN_OUT
  2761.   Create a stream for output from the specified file.
  2762. */
  2763. static long c_open_out()
  2764. {
  2765.   long success=FALSE;
  2766.   ptr_psi_term arg1,arg2,arg3,g;
  2767.   char *fn;
  2768.   
  2769.   g=aim->a;
  2770.   deref_ptr(g);
  2771.   get_two_args(g->attr_list,&arg1,&arg2);
  2772.   if(arg1) {
  2773.     deref(arg1);
  2774.     if (psi_to_string(arg1,&fn))
  2775.       if (arg2) {
  2776.     deref(arg2);
  2777.         deref(g);
  2778.     if (overlap_type(arg2->type,stream)) /* 10.8 */
  2779.       if (open_output_file(fn)) {
  2780.             arg3=stack_psi_term(4);
  2781.         arg3->type=stream;
  2782.         arg3->value=(GENERIC)output_stream;
  2783.         /* push_ptr_value(psi_term_ptr,&(arg2->coref)); 9.6 */
  2784.         push_psi_ptr_value(arg2,&(arg2->coref));
  2785.         arg2->coref=arg3;
  2786.         success=TRUE;
  2787.       }
  2788.       else
  2789.         success=FALSE;
  2790.     else
  2791.       Errorline("bad stream in %P.\n",g);
  2792.       }
  2793.       else
  2794.     Errorline("no stream in %P.\n",g);
  2795.     else
  2796.       Errorline("bad file name in %P.\n",g);
  2797.   }
  2798.   else
  2799.     Errorline("no file name in %P.\n",g);
  2800.   
  2801.   return success;
  2802. }
  2803.  
  2804.  
  2805.  
  2806. /******** C_SET_INPUT
  2807.   Set the current input stream to a given stream.
  2808.   If the given stream is closed, then do nothing.
  2809. */
  2810. static long c_set_input()
  2811. {
  2812.   long success=FALSE;
  2813.   ptr_psi_term arg1,arg2,g;
  2814.   FILE *thestream;
  2815.   
  2816.   g=aim->a;
  2817.   deref_ptr(g);
  2818.   get_two_args(g->attr_list,&arg1,&arg2);
  2819.   if (arg1) {
  2820.     deref(arg1);
  2821.     deref_args(g,set_1);
  2822.     if (equal_types(arg1->type,inputfilesym)) {
  2823.       success=TRUE;
  2824.       save_state(input_state);
  2825.       thestream=get_stream(arg1);
  2826.       if (thestream!=NULL) {
  2827.         input_state=arg1;
  2828.         restore_state(input_state);
  2829.       }
  2830.     }
  2831.     else
  2832.       Errorline("bad stream in %P.\n",g);
  2833.   }
  2834.   else
  2835.     Errorline("no stream in %P.\n",g);
  2836.   
  2837.   return success;
  2838. }
  2839.  
  2840.  
  2841.  
  2842. /******** C_SET_OUTPUT
  2843.   Set the current output stream.
  2844. */
  2845. static long c_set_output()
  2846. {
  2847.   long success=FALSE;
  2848.   ptr_psi_term arg1,arg2,g;
  2849.   
  2850.   g=aim->a;
  2851.   deref_ptr(g);
  2852.   get_two_args(g->attr_list,&arg1,&arg2);
  2853.   if(arg1) {
  2854.     deref(arg1);
  2855.     deref_args(g,set_1);
  2856.     if(equal_types(arg1->type,stream) && arg1->value) {
  2857.       success=TRUE;
  2858.       output_stream=(FILE *)arg1->value;
  2859.     }
  2860.     else
  2861.       Errorline("bad stream in %P.\n",g);
  2862.   }
  2863.   else
  2864.     Errorline("no stream in %P.\n",g);
  2865.   
  2866.   return success;
  2867. }
  2868.  
  2869. /******** C_CLOSE
  2870.   Close a stream.
  2871. */
  2872. static long c_close()
  2873. {
  2874.   long success=FALSE;
  2875.   long inclose,outclose;
  2876.   ptr_psi_term arg1,arg2,g,s;
  2877.   
  2878.   g=aim->a;
  2879.   deref_ptr(g);
  2880.   get_two_args(g->attr_list,&arg1,&arg2);
  2881.   if (arg1) {
  2882.     deref(arg1);
  2883.     deref_args(g,set_1);
  2884. /*
  2885.     if (sub_type(arg1->type,sys_stream))
  2886.       return sys_close(arg1);
  2887. */
  2888.     outclose=equal_types(arg1->type,stream) && arg1->value;
  2889.     inclose=FALSE;
  2890.     if (equal_types(arg1->type,inputfilesym)) {
  2891.       ptr_node n=find(featcmp,STREAM,arg1->attr_list);
  2892.       if (n) {
  2893.         arg1=(ptr_psi_term)n->data;
  2894.         inclose=(arg1->value!=NULL);
  2895.       }
  2896.     }
  2897.  
  2898.     if (inclose || outclose) {
  2899.       success=TRUE;
  2900.       fclose((FILE *)arg1->value);
  2901.       
  2902.       if (inclose && arg1->value==(GENERIC)input_stream)
  2903.     open_input_file("stdin");
  2904.       else if (outclose && arg1->value==(GENERIC)output_stream)
  2905.     open_output_file("stdout");
  2906.       
  2907.       arg1->value=NULL;
  2908.     }
  2909.     else
  2910.       Errorline("bad stream in %P.\n",g);
  2911.   }
  2912.   else
  2913.     Errorline("no stream in %P.\n",g);
  2914.   
  2915.   return success;
  2916. }
  2917.  
  2918.  
  2919.  
  2920.  
  2921. /******** C_GET
  2922.   Read the next character from the current input stream and return
  2923.   its Ascii code.  This includes blank characters, so this predicate
  2924.   differs slightly from Edinburgh Prolog's get(X).
  2925.   At end of file, return the psi-term 'end_of_file'.
  2926. */
  2927. static long c_get()
  2928. {
  2929.   long success=TRUE;
  2930.   ptr_psi_term arg1,arg2,g,t;
  2931.   long c;
  2932.   
  2933.   g=aim->a;
  2934.   deref_ptr(g);
  2935.   get_two_args(g->attr_list,&arg1,&arg2);
  2936.   if (arg1) {
  2937.     deref(arg1);
  2938.     deref_args(g,set_1);
  2939.  
  2940.     if (eof_flag) {
  2941.       success=FALSE;
  2942.     }
  2943.     else {
  2944.       prompt="";
  2945.       c=read_char();
  2946.       t=stack_psi_term(0);
  2947.       if (c==EOF) {
  2948.         t->type=eof;
  2949.         eof_flag=TRUE;
  2950.       }
  2951.       else {
  2952.         t->type=integer;
  2953.         t->value=heap_alloc(sizeof(REAL)); /* 12.5 */
  2954.         * (REAL *)t->value = (REAL) c;
  2955.       }
  2956.     }
  2957.     
  2958.     if (success) {
  2959.       push_goal(unify,t,arg1,NULL);
  2960.       i_check_out(t);
  2961.     }
  2962.   }
  2963.   else {
  2964.     Errorline("argument missing in %P.\n",g);
  2965.     success=FALSE;
  2966.   }
  2967.  
  2968.   return success;
  2969. }
  2970.  
  2971.  
  2972.  
  2973. /******** C_PUT, C_PUT_ERR
  2974.   Write the root of a psi-term to the current output stream or to stderr.
  2975.   This routine accepts the string type (which is written without quotes),
  2976.   a number type (whose integer part is considered an Ascii code if it is
  2977.   in the range 0..255), and any other psi-term (in which case its name is
  2978.   written).
  2979. */
  2980. static long c_put_main(); /* Forward declaration */
  2981.  
  2982. static long c_put()
  2983. {
  2984.   return c_put_main(FALSE);
  2985. }
  2986.  
  2987. static long c_put_err()
  2988. {
  2989.   return c_put_main(TRUE);
  2990. }
  2991.  
  2992. static long c_put_main(to_stderr)
  2993. long to_stderr;
  2994. {
  2995.   long i,success=FALSE;
  2996.   ptr_psi_term arg1,arg2,g;
  2997.   char tstr[2], *str=tstr;
  2998.   
  2999.   g=aim->a;
  3000.   deref_ptr(g);
  3001.   get_two_args(g->attr_list,&arg1,&arg2);
  3002.   if (arg1) {
  3003.     deref(arg1);
  3004.     deref_args(g,set_1);
  3005.     if ((equal_types(arg1->type,integer) || equal_types(arg1->type,real))
  3006.         && arg1->value) {
  3007.       i = (unsigned long) floor(*(REAL *) arg1->value);
  3008.       if (i==(unsigned long)(unsigned char)i) {
  3009.         str[0] = i; str[1] = 0;
  3010.         success=TRUE;
  3011.       }
  3012.       else {
  3013.         Errorline("out-of-range character value in %P.\n",g);
  3014.       }
  3015.     }
  3016.     else if (psi_to_string(arg1,&str)) {
  3017.       success=TRUE;
  3018.     }
  3019.     if (success)
  3020.       fprintf((to_stderr?stderr:output_stream),"%s",str);
  3021.   }
  3022.   else
  3023.     Errorline("argument missing in %P.\n",g);
  3024.   
  3025.   return success;
  3026. }
  3027.  
  3028.  
  3029.  
  3030. /******** GENERIC_WRITE
  3031.   Implements write, writeq, pretty_write, pretty_writeq.
  3032. */
  3033. static long generic_write()
  3034. {
  3035.   ptr_psi_term g;
  3036.  
  3037.   g=aim->a;
  3038.   /* deref_rec(g); */
  3039.   deref_args(g,set_empty);
  3040.   pred_write(g->attr_list);
  3041.   /* fflush(output_stream); */
  3042.   return TRUE;
  3043. }
  3044.  
  3045. /******** C_WRITE_ERR
  3046.   Write a list of arguments to stderr.  Print cyclical terms
  3047.   correctly, but don't use the pretty printer indentation.
  3048. */
  3049. static long c_write_err()
  3050. {
  3051.   indent=FALSE;
  3052.   const_quote=FALSE;
  3053.   write_stderr=TRUE;
  3054.   write_corefs=FALSE;
  3055.   write_resids=FALSE;
  3056.   write_canon=FALSE;
  3057.   return generic_write();
  3058. }
  3059.  
  3060. /******** C_WRITEQ_ERR
  3061.   Write a list of arguments to stderr in a form that allows them to be
  3062.   read in again.  Print cyclical terms correctly, but don't use the pretty
  3063.   printer indentation.
  3064. */
  3065. static long c_writeq_err()
  3066. {
  3067.   indent=FALSE;
  3068.   const_quote=TRUE;
  3069.   write_stderr=TRUE;
  3070.   write_corefs=FALSE;
  3071.   write_resids=FALSE;
  3072.   write_canon=FALSE;
  3073.   return generic_write();
  3074. }
  3075.  
  3076. /******** C_WRITE
  3077.   Write a list of arguments. Print cyclical terms
  3078.   correctly, but don't use the pretty printer indentation.
  3079. */
  3080. static long c_write()
  3081. {
  3082.   indent=FALSE;
  3083.   const_quote=FALSE;
  3084.   write_stderr=FALSE;
  3085.   write_corefs=FALSE;
  3086.   write_resids=FALSE;
  3087.   write_canon=FALSE;
  3088.   return generic_write();
  3089. }
  3090.  
  3091. /******** C_WRITEQ
  3092.   Write a list of arguments in a form that allows them to be read in
  3093.   again.  Print cyclical terms correctly, but don't use the pretty
  3094.   printer indentation.
  3095. */
  3096. static long c_writeq()
  3097. {
  3098.   indent=FALSE;
  3099.   const_quote=TRUE;
  3100.   write_stderr=FALSE;
  3101.   write_corefs=FALSE;
  3102.   write_resids=FALSE;
  3103.   write_canon=FALSE;
  3104.   return generic_write();
  3105. }
  3106.  
  3107. /******** C_WRITE_CANONICAL
  3108.   Write a list of arguments in a form that allows them to be read in
  3109.   again.  Print cyclical terms correctly, but don't use the pretty
  3110.   printer indentation.
  3111. */
  3112. static long c_write_canonical()
  3113. {
  3114.   indent=FALSE;
  3115.   const_quote=TRUE;
  3116.   write_stderr=FALSE;
  3117.   write_corefs=FALSE;
  3118.   write_resids=FALSE;
  3119.   write_canon=TRUE;
  3120.   return generic_write();
  3121. }
  3122.  
  3123. /******** C_PRETTY_WRITE
  3124.   The same as write, only indenting if output is wider than PAGEWIDTH.
  3125. */
  3126. static long c_pwrite()
  3127. {
  3128.   indent=TRUE;
  3129.   const_quote=FALSE;
  3130.   write_stderr=FALSE;
  3131.   write_corefs=FALSE;
  3132.   write_resids=FALSE;
  3133.   write_canon=FALSE;
  3134.   return generic_write();
  3135. }
  3136.  
  3137.  
  3138. /******** C_PRETTY_WRITEQ
  3139.   The same as writeq, only indenting if output is wider than PAGEWIDTH.
  3140. */
  3141. static long c_pwriteq()
  3142. {
  3143.   indent=TRUE;
  3144.   const_quote=TRUE;
  3145.   write_stderr=FALSE;
  3146.   write_corefs=FALSE;
  3147.   write_resids=FALSE;
  3148.   write_canon=FALSE;
  3149.   return generic_write();
  3150. }
  3151.  
  3152.  
  3153.  
  3154. /******** C_PAGE_WIDTH
  3155.   Set the page width.
  3156. */
  3157. static long c_page_width()
  3158. {
  3159.   long success=FALSE;
  3160.   ptr_psi_term arg1,arg2,g;
  3161.   long pw;
  3162.   
  3163.   g=aim->a;
  3164.   deref_ptr(g);
  3165.   get_two_args(g->attr_list,&arg1,&arg2);
  3166.   if(arg1) {
  3167.     deref(arg1);
  3168.     deref_args(g,set_1);
  3169.     if (equal_types(arg1->type,integer) && arg1->value) {
  3170.       pw = *(REAL *)arg1->value;
  3171.       if (pw>0)
  3172.         page_width=pw;
  3173.       else
  3174.         Errorline("argument in %P must be positive.\n",g);
  3175.       success=TRUE;
  3176.     }
  3177.     else if (sub_type(integer,arg1->type)) {
  3178.       push_goal(unify,arg1,real_stack_psi_term(4,(REAL)page_width),NULL);
  3179.       success=TRUE;
  3180.     }
  3181.     else
  3182.       Errorline("bad argument in %P.\n",g);
  3183.   }
  3184.   else
  3185.     Errorline("argument missing in %P.\n",g);
  3186.   
  3187.   return success;
  3188. }
  3189.  
  3190.  
  3191.  
  3192. /******** C_PRINT_DEPTH
  3193.   Set the depth limit of printing.
  3194. */
  3195. static long c_print_depth()
  3196. {
  3197.   long success=FALSE;
  3198.   ptr_psi_term arg1,arg2,g;
  3199.   long dl;
  3200.   
  3201.   g=aim->a;
  3202.   deref_ptr(g);
  3203.   get_two_args(g->attr_list,&arg1,&arg2);
  3204.   if (arg1) {
  3205.     deref(arg1);
  3206.     deref_args(g,set_1);
  3207.     if (equal_types(arg1->type,integer) && arg1->value) {
  3208.       dl = *(REAL *)arg1->value;
  3209.       if (dl>=0)
  3210.         print_depth=dl;
  3211.       else
  3212.         Errorline("argument in %P must be positive or zero.\n",g);
  3213.       success=TRUE;
  3214.     }
  3215.     else if (sub_type(integer,arg1->type)) {
  3216.       push_goal(unify,arg1,real_stack_psi_term(4,(REAL)print_depth),NULL);
  3217.       success=TRUE;
  3218.     }
  3219.     else
  3220.       Errorline("bad argument in %P.\n",g);
  3221.   }
  3222.   else {
  3223.     /* No arguments: reset print depth to default value */
  3224.     print_depth=PRINT_DEPTH;
  3225.     success=TRUE;
  3226.   }
  3227.   
  3228.   return success;
  3229. }
  3230.  
  3231.  
  3232.  
  3233. /******** C_ROOTSORT
  3234.   Return the principal sort of the argument == create a copy with the
  3235.   attributes detached.
  3236. */
  3237. static long c_rootsort()
  3238. {
  3239.   long success=TRUE;
  3240.   ptr_psi_term arg1,arg2,arg3,g,other;
  3241.   
  3242.   g=aim->a;
  3243.   deref_ptr(g);
  3244.   arg3=aim->b;
  3245.   deref(arg3);
  3246.   get_two_args(g->attr_list,&arg1,&arg2);
  3247.   if(arg1) {
  3248.     deref(arg1);
  3249.     deref_args(g,set_1);
  3250.     other=stack_psi_term(4); /* 19.11 */
  3251.     other->type=arg1->type;    
  3252.     other->value=arg1->value;
  3253.     resid_aim=NULL;
  3254.     push_goal(unify,arg3,other,NULL);
  3255.   }
  3256.   else
  3257.     curry();
  3258.   
  3259.   return success;
  3260. }
  3261.  
  3262.  
  3263.  
  3264.  
  3265. /******** C_DISJ
  3266.   This implements disjunctions (A;B).
  3267.   A nonexistent A or B is taken to mean 'fail'.
  3268.   Disjunctions should not be implemented in Life, because doing so results in
  3269.   both A and B being evaluated before the disjunction is.
  3270.   Disjunctions could be implemented in Life if there were a 'melt' predicate.
  3271.   */
  3272. static long c_disj()
  3273. {
  3274.   long success=TRUE;
  3275.   ptr_psi_term arg1,arg2,g;
  3276.  
  3277.   g=aim->a;
  3278.   resid_aim=NULL;
  3279.   deref_ptr(g);
  3280.   get_two_args(g->attr_list,&arg1,&arg2);
  3281.   deref_args(g,set_1_2);
  3282.   Traceline("pushing predicate disjunction choice point for %P\n",g);
  3283.   if (arg2) push_choice_point(prove,arg2,DEFRULES,NULL);
  3284.   if (arg1) push_goal(prove,arg1,DEFRULES,NULL);
  3285.   if (!arg1 && !arg2) {
  3286.     success=FALSE;
  3287.     Errorline("neither first nor second arguments exist in %P.\n",g);
  3288.   }
  3289.  
  3290.   return success;
  3291. }
  3292.  
  3293.  
  3294.  
  3295. /******** C_COND
  3296.   This implements COND(Condition,Then,Else).
  3297.   First Condition is evaluated.  If it returns true, return the Then value.
  3298.   If it returns false, return the Else value.  Either the Then or the Else
  3299.   values may be omitted, in which case they are considered to be true.
  3300. */
  3301. static long c_cond()
  3302. {
  3303.   long success=TRUE;
  3304.   ptr_psi_term arg1,arg2,result,g;
  3305.   ptr_psi_term *arg1addr;
  3306.   REAL val1;
  3307.   long num1;
  3308.   ptr_node n;
  3309.   
  3310.   g=aim->a;
  3311.   deref_ptr(g);
  3312.   result=aim->b;
  3313.   deref(result);
  3314.   
  3315.   get_one_arg_addr(g->attr_list,&arg1addr);
  3316.   if (arg1addr) {
  3317.     arg1= *arg1addr;
  3318.     deref_ptr(arg1);
  3319.     if (arg1->type->type==predicate) {
  3320.       ptr_psi_term call_once;
  3321.       ptr_node ca;
  3322.  
  3323.       /* Transform cond(pred,...) into cond(call_once(pred),...) */
  3324.       goal_stack=aim;
  3325.       call_once=stack_psi_term(0);
  3326.       call_once->type=calloncesym;
  3327.       call_once->attr_list=(ca=STACK_ALLOC(node));
  3328.       ca->key=one;
  3329.       ca->left=ca->right=NULL;
  3330.       ca->data=(GENERIC)arg1;
  3331.       push_ptr_value(psi_term_ptr,arg1addr);
  3332.       *arg1addr=call_once;
  3333.       return success;
  3334.     }
  3335.     deref(arg1);
  3336.     deref_args(g,set_1_2_3);
  3337.     success=get_bool_value(arg1,&val1,&num1);
  3338.     if (success) {
  3339.       if (num1) {
  3340.     resid_aim=NULL;
  3341.         n=find(featcmp,(val1?two:three),g->attr_list);
  3342.         if (n) {
  3343.           arg2=(ptr_psi_term)n->data;
  3344.       /* mark_eval(arg2); XXX 24.8 */
  3345.       push_goal(unify,result,arg2,NULL);
  3346.       i_check_out(arg2);
  3347.         }
  3348.         else {
  3349.           ptr_psi_term trueterm;
  3350.           trueterm=stack_psi_term(4);
  3351.           trueterm->type=true;
  3352.           push_goal(unify,result,trueterm,NULL);
  3353.         }
  3354.       }
  3355.       else
  3356.         residuate(arg1);
  3357.     }
  3358.     else /*  RM: Apr 15 1993  */
  3359.       Errorline("argument to cond is not boolean in %P\n",g);
  3360.   }
  3361.   else
  3362.     curry();
  3363.   
  3364.   return success;
  3365. }
  3366.  
  3367.  
  3368.  
  3369. /******** C_EXIST_FEATURE
  3370.   Here we evaluate "has_feature(Label,Psi-term,Value)". This
  3371.   is a boolean function that returns true iff Psi-term
  3372.   has the feature Label.
  3373.  
  3374.   Added optional 3rd argument which is unified with the feature value if it exists.
  3375.   */
  3376.  
  3377. static long c_exist_feature()  /*  PVR: Dec 17 1992  */  /* PVR 11.4.94 */
  3378. {
  3379.   long success=TRUE,v;
  3380.   ptr_psi_term arg1,arg2,arg3,funct,result,ans;
  3381.   ptr_node n;
  3382.   char *label;
  3383.   /* char *thebuffer="integer"; 18.5 */
  3384.   char thebuffer[20]; /* Maximum number of digits in an integer */
  3385.  
  3386.   funct=aim->a;
  3387.   deref_ptr(funct);
  3388.   result=aim->b;
  3389.   get_two_args(funct->attr_list,&arg1,&arg2);
  3390.  
  3391.   
  3392.   n=find(featcmp,three,funct->attr_list,&arg3); /*  RM: Feb 10 1993  */
  3393.   if(n)
  3394.     arg3=(ptr_psi_term)n->data;
  3395.   else
  3396.     arg3=NULL;
  3397.   
  3398.   if (arg1 && arg2) {
  3399.     deref(arg1);
  3400.     deref(arg2);
  3401.     
  3402.     if(arg3) /*  RM: Feb 10 1993  */
  3403.       deref(arg3);
  3404.     
  3405.     deref_args(funct,set_1_2);
  3406.     label=NULL;
  3407.     
  3408.     if (arg1->value && sub_type(arg1->type,quoted_string))
  3409.       label=(char *)arg1->value;
  3410.     else if (arg1->value && sub_type(arg1->type,integer)) {
  3411.       v= *(REAL *)arg1->value;
  3412.       sprintf(thebuffer,"%ld",(long)v);
  3413.       label=heap_copy_string(thebuffer); /* A little voracious */
  3414.     } else if (arg1->type->keyword->private_feature) {
  3415.       label=arg1->type->keyword->combined_name;
  3416.     } else
  3417.       label=arg1->type->keyword->symbol;
  3418.  
  3419.     n=find(featcmp,label,arg2->attr_list);
  3420.     ans=stack_psi_term(4);
  3421.     ans->type=(n!=NULL)?true:false;
  3422.       
  3423.     if(arg3 && n) /*  RM: Feb 10 1993  */
  3424.       push_goal(unify,arg3,n->data,NULL);
  3425.       
  3426.     push_goal(unify,result,ans,NULL);
  3427.   }
  3428.   else
  3429.     curry();
  3430.  
  3431.   return success;
  3432. }
  3433.  
  3434.  
  3435.  
  3436.  
  3437. /******** C_FEATURES
  3438.   Convert the feature names of a psi_term into a list of psi-terms.
  3439.   This uses the MAKE_FEATURE_LIST routine.
  3440. */
  3441. static long c_features()
  3442. {
  3443.   long success=TRUE;
  3444.   ptr_psi_term arg1,arg2,funct,result;
  3445.   ptr_psi_term the_list; /*  RM: Dec  9 1992
  3446.                  Modified the routine to use 'cons'
  3447.                  instead of the old list representation.
  3448.                  */
  3449.   /*  RM: Mar 11 1993  Added MODULE argument */
  3450.   ptr_module module=NULL;
  3451.   ptr_module save_current;
  3452.  
  3453.  
  3454.  
  3455.   
  3456.   funct=aim->a;
  3457.   deref_ptr(funct);
  3458.   result=aim->b;
  3459.   get_two_args(funct->attr_list,&arg1,&arg2);
  3460.  
  3461.   
  3462.   if(arg2) {
  3463.     deref(arg2);
  3464.     success=get_module(arg2,&module);
  3465.   }
  3466.   else
  3467.     module=current_module;
  3468.  
  3469.   
  3470.   if(arg1 && success) {
  3471.     deref(arg1);
  3472.     deref_args(funct,set_1);
  3473.     resid_aim=NULL;
  3474.  
  3475.     save_current=current_module;
  3476.     if(module)
  3477.       current_module=module;
  3478.     
  3479.     push_goal(unify,
  3480.           result,
  3481.           make_feature_list(arg1->attr_list,stack_nil(),module,0),
  3482.           NULL);
  3483.     
  3484.     current_module=save_current;
  3485.   }
  3486.   else
  3487.     curry();
  3488.   
  3489.   return success;
  3490. }
  3491.  
  3492.  
  3493.  
  3494. /******** C_FEATURES
  3495.   Return the list of values of the features of a term.
  3496.   */
  3497. static long c_feature_values()
  3498. {
  3499.   long success=TRUE;
  3500.   ptr_psi_term arg1,arg2,funct,result;
  3501.   ptr_psi_term the_list; /*  RM: Dec  9 1992
  3502.                  Modified the routine to use 'cons'
  3503.                  instead of the old list representation.
  3504.                  */
  3505.   /*  RM: Mar 11 1993  Added MODULE argument */
  3506.   ptr_module module=NULL;
  3507.   ptr_module save_current;
  3508.  
  3509.   
  3510.   funct=aim->a;
  3511.   deref_ptr(funct);
  3512.   result=aim->b;
  3513.   get_two_args(funct->attr_list,&arg1,&arg2);
  3514.  
  3515.   
  3516.   if(arg2) {
  3517.     deref(arg2);
  3518.     success=get_module(arg2,&module);
  3519.   }
  3520.   else
  3521.     module=current_module;
  3522.  
  3523.   
  3524.   if(arg1 && success) {
  3525.     deref(arg1);
  3526.     deref_args(funct,set_1);
  3527.     resid_aim=NULL;
  3528.  
  3529.     save_current=current_module;
  3530.     if(module)
  3531.       current_module=module;
  3532.     
  3533.     push_goal(unify,
  3534.           result,
  3535.           make_feature_list(arg1->attr_list,stack_nil(),module,1),
  3536.           NULL);
  3537.     
  3538.     current_module=save_current;
  3539.   }
  3540.   else
  3541.     curry();
  3542.   
  3543.   return success;
  3544. }
  3545.  
  3546.  
  3547.  
  3548. /* Return TRUE iff T is a type that should not show up as part of the
  3549.    type hierarchy, i.e. it is an internal hidden type. */
  3550. long hidden_type(t)
  3551. ptr_definition t;
  3552. {
  3553.    return (/* (t==conjunction) || 19.8 */
  3554.        /* (t==disjunction) || RM: Dec  9 1992 */
  3555.            (t==constant) || (t==variable) ||
  3556.            (t==comment) || (t==functor));
  3557. }
  3558.  
  3559.  
  3560.  
  3561. /* Collect properties of the symbols in the symbol table, and make a
  3562.    psi-term list of them.
  3563.    This routine is parameterized (by sel) to collect three properties:
  3564.    1. All symbols that are types with no parents.
  3565.    2. All symbols that are of 'undef' type.
  3566.    3. The operator triples of all operators.
  3567.  
  3568.    Note the similarity between this routine and a tree-to-list
  3569.    routine in Prolog.  The pointer manipulations are simpler in
  3570.    Prolog, though.
  3571.  
  3572.    If the number of symbols is very large, this routine may run out of space
  3573.    before garbage collection.
  3574. */
  3575. ptr_psi_term collect_symbols(sel) /*  RM: Feb  3 1993  */
  3576.      long sel;
  3577.  
  3578. {
  3579.   ptr_psi_term new;
  3580.   ptr_definition def;
  3581.   long botflag;
  3582.   ptr_psi_term result;
  3583.  
  3584.  
  3585.   result=stack_nil();
  3586.   
  3587.   for(def=first_definition;def;def=def->next) {
  3588.  
  3589.     if (sel==least_sel || sel==greatest_sel) {
  3590.       botflag=(sel==least_sel);
  3591.  
  3592.       /* Insert the node if it's a good one */
  3593.       if (((botflag?def->children:def->parents)==NULL &&
  3594.            def!=top && def!=nothing &&
  3595.            def->type==type ||
  3596.            def->type==undef)
  3597.           && !hidden_type(def)) {
  3598.         /* Create the node that will be inserted */
  3599.         new=stack_psi_term(4);
  3600.         new->type=def;
  3601.     result=stack_cons(new,result);
  3602.       }
  3603.     }
  3604.     else if (sel==op_sel) {
  3605.       ptr_operator_data od=def->op_data;
  3606.  
  3607.       while (od) {
  3608.         ptr_psi_term name,type;
  3609.  
  3610.     new=stack_psi_term(4);
  3611.         new->type=opsym;
  3612.     result=stack_cons(new,result);
  3613.     
  3614.         stack_add_int_attr(new,one,od->precedence);
  3615.  
  3616.         type=stack_psi_term(4);
  3617.         switch (od->type) {
  3618.         case xf:
  3619.           type->type=xf_sym;
  3620.           break;
  3621.         case yf:
  3622.           type->type=yf_sym;
  3623.           break;
  3624.         case fx:
  3625.           type->type=fx_sym;
  3626.           break;
  3627.         case fy:
  3628.           type->type=fy_sym;
  3629.           break;
  3630.         case xfx:
  3631.           type->type=xfx_sym;
  3632.           break;
  3633.         case xfy:
  3634.           type->type=xfy_sym;
  3635.           break;
  3636.         case yfx:
  3637.           type->type=yfx_sym;
  3638.           break;
  3639.         }
  3640.         stack_add_psi_attr(new,two,type);
  3641.  
  3642.         name=stack_psi_term(4);
  3643.         name->type=def;
  3644.         stack_add_psi_attr(new,three,name);
  3645.  
  3646.         od=od->next;
  3647.       }
  3648.     }
  3649.   }
  3650.   
  3651.   return result;
  3652. }
  3653.  
  3654.  
  3655.  
  3656. /******** C_OPS
  3657.   Return a list of all operators (represented as 3-tuples op(prec,type,atom)).
  3658.   This function has no arguments.
  3659. */
  3660. static long c_ops()
  3661. {
  3662.   long success=TRUE;
  3663.   ptr_psi_term result, g, t;
  3664.  
  3665.   g=aim->a;
  3666.   deref_args(g,set_empty);
  3667.   result=aim->b;
  3668.   t=collect_symbols(op_sel);   /*  RM: Feb  3 1993  */
  3669.   push_goal(unify,result,t,NULL);
  3670.  
  3671.   return success;
  3672. }
  3673.  
  3674.  
  3675.  
  3676.  
  3677. /* PVR 23.2.94 -- Added this to fix c_strip and c_copy_pointer */
  3678. /* Make a copy of an attr_list structure, keeping the same leaf pointers */
  3679. static ptr_node copy_attr_list(n)
  3680. ptr_node n;
  3681. {
  3682.   ptr_node m;
  3683.  
  3684.   if (n==NULL) return NULL;
  3685.  
  3686.   m = STACK_ALLOC(node);
  3687.   m->key = n->key;
  3688.   m->data = n->data;
  3689.   m->left = copy_attr_list(n->left);
  3690.   m->right = copy_attr_list(n->right);
  3691.   return m;
  3692. }
  3693.  
  3694.  
  3695. /******** C_STRIP
  3696.   Return the attributes of a psi-term, that is, a psi-term of type @ but with
  3697.   all the attributes of the argument.
  3698. */
  3699. static long c_strip()
  3700. {
  3701.   long success=TRUE;
  3702.   ptr_psi_term arg1,arg2,funct,result;
  3703.   
  3704.   funct=aim->a;
  3705.   deref_ptr(funct);
  3706.   result=aim->b;
  3707.   get_two_args(funct->attr_list,&arg1,&arg2);
  3708.   if(arg1) {
  3709.     deref(arg1);
  3710.     deref_args(funct,set_1);
  3711.     resid_aim=NULL;
  3712.     /* PVR 23.2.94 */
  3713.     merge_unify(&(result->attr_list),copy_attr_list(arg1->attr_list));
  3714.   }
  3715.   else
  3716.     curry();
  3717.   
  3718.   return success;
  3719. }
  3720.  
  3721.  
  3722.  
  3723.  
  3724. /******** C_SAME_ADDRESS
  3725.   Return TRUE if two arguments share the same address.
  3726. */
  3727. static long c_same_address()
  3728. {
  3729.   long success=TRUE;
  3730.   ptr_psi_term arg1,arg2,funct,result;
  3731.   REAL val3;
  3732.   long num3;
  3733.   
  3734.   funct=aim->a;
  3735.   deref_ptr(funct);
  3736.   result=aim->b;
  3737.   get_two_args(funct->attr_list,&arg1,&arg2);
  3738.   
  3739.   if (arg1 && arg2) {
  3740.     success=get_bool_value(result,&val3,&num3);
  3741.     resid_aim=NULL;
  3742.     deref(arg1);
  3743.     deref(arg2);
  3744.     deref_args(funct,set_1_2);
  3745.     
  3746.     if (num3) {
  3747.       if (val3)
  3748.     push_goal(unify,arg1,arg2,NULL);
  3749.       else
  3750.     success=(arg1!=arg2);
  3751.     }
  3752.     else
  3753.       if (arg1==arg2)
  3754.     unify_bool_result(result,TRUE);
  3755.       else
  3756.     unify_bool_result(result,FALSE);
  3757.   }
  3758.   else
  3759.     curry();
  3760.   
  3761.   return success;
  3762. }
  3763.  
  3764.  
  3765.  
  3766. /******** C_DIFF_ADDRESS
  3767.   Return TRUE if two arguments have different addresses.
  3768. */
  3769. static long c_diff_address()
  3770. {
  3771.   long success=TRUE;
  3772.   ptr_psi_term arg1,arg2,funct,result;
  3773.   REAL val3;
  3774.   long num3;
  3775.   
  3776.   funct=aim->a;
  3777.   deref_ptr(funct);
  3778.   result=aim->b;
  3779.   get_two_args(funct->attr_list,&arg1,&arg2);
  3780.   
  3781.   if (arg1 && arg2) {
  3782.     success=get_bool_value(result,&val3,&num3);
  3783.     resid_aim=NULL;
  3784.     deref(arg1);
  3785.     deref(arg2);
  3786.     deref_args(funct,set_1_2);
  3787.     
  3788.     if (num3) {
  3789.       if (val3)
  3790.     push_goal(unify,arg1,arg2,NULL);
  3791.       else
  3792.     success=(arg1==arg2);
  3793.     }
  3794.     else
  3795.       if (arg1==arg2)
  3796.     unify_bool_result(result,FALSE);
  3797.       else
  3798.     unify_bool_result(result,TRUE);
  3799.   }
  3800.   else
  3801.     curry();
  3802.   
  3803.   return success;
  3804. }
  3805.  
  3806.  
  3807.  
  3808.  
  3809. /******** C_EVAL
  3810.   Evaluate an expression and return its value.
  3811. */
  3812. static long c_eval()
  3813. {
  3814.   long success=TRUE;
  3815.   ptr_psi_term arg1, copy_arg1, arg2, funct, result;
  3816.  
  3817.   funct = aim->a;
  3818.   deref_ptr(funct);
  3819.   result = aim->b;
  3820.   deref(result);
  3821.   get_two_args(funct->attr_list, &arg1, &arg2);
  3822.   if (arg1) {
  3823.     deref(arg1);
  3824.     deref_args(funct,set_1);
  3825.     assert((unsigned long)(arg1->type)!=4);
  3826.     clear_copy();
  3827.     copy_arg1 = eval_copy(arg1,STACK);
  3828.     resid_aim = NULL;
  3829.     push_goal(unify,copy_arg1,result,NULL);
  3830.     i_check_out(copy_arg1);
  3831.   } else
  3832.     curry();
  3833.  
  3834.   return success;
  3835. }
  3836.  
  3837.  
  3838.  
  3839.  
  3840. /******** C_EVAL_INPLACE
  3841.   Evaluate an expression and return its value.
  3842. */
  3843. static long c_eval_inplace()
  3844. {
  3845.   long success=TRUE;
  3846.   ptr_psi_term arg1, copy_arg1, arg2, funct, result;
  3847.  
  3848.   funct = aim->a;
  3849.   deref_ptr(funct);
  3850.   result = aim->b;
  3851.   deref(result);
  3852.   get_two_args(funct->attr_list, &arg1, &arg2);
  3853.   if (arg1) {
  3854.     deref(arg1);
  3855.     deref_args(funct,set_1);
  3856.     resid_aim = NULL;
  3857.     mark_eval(arg1);
  3858.     push_goal(unify,arg1,result,NULL);
  3859.     i_check_out(arg1);
  3860.   } else
  3861.     curry();
  3862.  
  3863.   return success;
  3864. }
  3865.  
  3866.  
  3867.  
  3868.  
  3869. /******** C_QUOTE
  3870.   Quote an expression, i.e. do not evaluate it but mark it as completely
  3871.   evaluated.
  3872.   This works if the function is declared as non_strict.
  3873. */
  3874. static long c_quote()
  3875. {
  3876.   long success=TRUE;
  3877.   ptr_psi_term arg1,arg2,funct,result;
  3878.  
  3879.   funct = aim->a;
  3880.   deref_ptr(funct);
  3881.   result = aim->b;
  3882.   deref(result);
  3883.   get_two_args(funct->attr_list, &arg1, &arg2);
  3884.   if (arg1) {
  3885.     push_goal(unify,arg1,result,NULL);
  3886.   } else
  3887.     curry();
  3888.  
  3889.   return success;
  3890. }
  3891.  
  3892.  
  3893.  
  3894. /******** C_SPLIT_DOUBLE
  3895.   Split a double into two 32-bit words.
  3896.   */
  3897.  
  3898. static long c_split_double()
  3899. {
  3900.   long success=FALSE;
  3901.   ptr_psi_term arg1,arg2,funct,result;
  3902.   int n;
  3903.   union {
  3904.     double d;
  3905.     struct {
  3906.       int hi;
  3907.       int lo;
  3908.     } w2;
  3909.   }hack;
  3910.   double hi,lo;
  3911.   int n1,n2;
  3912.   
  3913.   funct = aim->a;
  3914.   deref_ptr(funct);
  3915.   result=aim->b;
  3916.   
  3917.   get_two_args(funct->attr_list, &arg1, &arg2);
  3918.   if(arg1 && arg2) {
  3919.     deref_ptr(arg1);
  3920.     deref_ptr(arg2);
  3921.     deref_ptr(result);
  3922.     if(get_real_value(result,&(hack.d),&n)  &&
  3923.        get_real_value(arg1  ,&hi      ,&n1) &&
  3924.        get_real_value(arg2  ,&lo      ,&n2)) {
  3925.       
  3926.       
  3927.       if(n) {
  3928.     unify_real_result(arg1,(REAL)hack.w2.hi);
  3929.     unify_real_result(arg2,(REAL)hack.w2.lo);
  3930.     success=TRUE;
  3931.       }
  3932.       else
  3933.     if(n1 && n2) {
  3934.       hack.w2.hi=(int)hi;
  3935.       hack.w2.lo=(int)lo;
  3936.       unify_real_result(result,hack.d);
  3937.       success=TRUE;
  3938.     }
  3939.     else {
  3940.       residuate(result);
  3941.       residuate2(arg1,arg2);
  3942.     }
  3943.     }
  3944.     else
  3945.       Errorline("non-numeric arguments in %P\n",funct);
  3946.   }
  3947.   else
  3948.     curry();
  3949.   
  3950.   return success;
  3951. }
  3952.  
  3953.  
  3954.  
  3955. /******** C_STRING_ADDRESS
  3956.   Return the address of a string.
  3957.   */
  3958.  
  3959. static long c_string_address()
  3960. {
  3961.   long success=FALSE;
  3962.   ptr_psi_term arg1,arg2,funct,result,t;
  3963.   double val;
  3964.   int num;
  3965.   int smaller;
  3966.   
  3967.   
  3968.   funct = aim->a;
  3969.   deref_ptr(funct);
  3970.   result=aim->b;
  3971.   
  3972.   get_two_args(funct->attr_list, &arg1, &arg2);
  3973.   if(arg1) {
  3974.     deref_ptr(arg1);
  3975.     deref_ptr(result);
  3976.       success=matches(arg1->type,quoted_string,&smaller);
  3977.       if (success) {
  3978.     if (arg1->value) {
  3979.       unify_real_result(result,(REAL)(long)(arg1->value));
  3980.     }
  3981.     else {
  3982.       if(success=get_real_value(result,&val,&num)) {
  3983.         if(num) {
  3984.           t=stack_psi_term(4);
  3985.           t->type=quoted_string;
  3986.           t->value=(GENERIC)(long)val;
  3987.           push_goal(unify,t,arg1,NULL);
  3988.         }
  3989.         else
  3990.           residuate2(arg1,result);
  3991.       
  3992.       }
  3993.       else
  3994.         Errorline("result is not a real in %P\n",funct);
  3995.     }
  3996.       }
  3997.       else
  3998.     Errorline("argument is not a string in %P\n",funct);
  3999.   }
  4000.   else
  4001.     curry();
  4002.   
  4003.   return success;
  4004. }
  4005.  
  4006.  
  4007.  
  4008. /******** C_CHDIR
  4009.   Change the current working directory
  4010.   */
  4011.  
  4012. static long c_chdir()
  4013. {
  4014.   long success=FALSE;
  4015.   ptr_psi_term arg1,arg2,funct,result,t;
  4016.   double val;
  4017.   int num;
  4018.   int smaller;
  4019.   
  4020.   
  4021.   funct = aim->a;
  4022.   deref_ptr(funct);
  4023.   
  4024.   get_two_args(funct->attr_list, &arg1, &arg2);
  4025.   if(arg1) {
  4026.     deref_ptr(arg1);
  4027.     if(matches(arg1->type,quoted_string,&smaller) && arg1->value)
  4028.       success=!chdir(expand_file_name((char *)arg1->value));
  4029.     else
  4030.       Errorline("bad argument in %P\n",funct);
  4031.   }
  4032.   else
  4033.     Errorline("argument missing in %P\n",funct);
  4034.   
  4035.   return success;
  4036. }
  4037.  
  4038.  
  4039.  
  4040. /******** C_CALL_ONCE
  4041.   Prove a predicate, return true or false if it succeeds or fails.
  4042.   An implicit cut is performed: only only solution is given.
  4043. */
  4044. #if 0    /* DENYS Jan 25 1995 */
  4045. static long c_call_once()
  4046. {
  4047.   long success=TRUE;
  4048.   ptr_psi_term arg1,arg2,funct,result,other;
  4049.   ptr_choice_point cutpt; 
  4050.  
  4051.   funct=aim->a;
  4052.   deref_ptr(funct);
  4053.   result=aim->b;
  4054.   get_two_args(funct->attr_list,&arg1,&arg2);
  4055.   if (arg1) {
  4056.     deref_ptr(arg1);
  4057.     deref_args(funct,set_1);
  4058.     if(arg1->type==top)
  4059.       residuate(arg1);
  4060.     else
  4061.       if(FALSE /*arg1->type->type!=predicate*/) {
  4062.         success=FALSE;
  4063.         Errorline("argument of %P should be a predicate.\n",funct);
  4064.       }
  4065.       else {
  4066.     resid_aim=NULL;
  4067.         cutpt=choice_stack;
  4068.  
  4069.         /* Result is FALSE */
  4070.         other=stack_psi_term(0);
  4071.         other->type=false;
  4072.  
  4073.         push_choice_point(unify,result,other,NULL);
  4074.  
  4075.         /* Result is TRUE */
  4076.         other=stack_psi_term(0);
  4077.         other->type=true;
  4078.  
  4079.         push_goal(unify,result,other,NULL);
  4080.         push_goal(eval_cut,other,cutpt,NULL);
  4081.         push_goal(prove,arg1,DEFRULES,NULL);
  4082.       }
  4083.   }
  4084.   else
  4085.     curry();
  4086.  
  4087.   return success;
  4088. }
  4089. #endif
  4090.  
  4091.  
  4092.  
  4093. /******** C_CALL
  4094.   Prove a predicate, return true or false if it succeeds or fails.
  4095.   No implicit cut is performed.
  4096. */
  4097. static long c_call()
  4098. {
  4099.   long success=TRUE;
  4100.   ptr_psi_term arg1,arg2,funct,result,other;
  4101.   ptr_choice_point cutpt; 
  4102.  
  4103.   funct=aim->a;
  4104.   deref_ptr(funct);
  4105.   result=aim->b;
  4106.   get_two_args(funct->attr_list,&arg1,&arg2);
  4107.   if (arg1) {
  4108.     deref_ptr(arg1);
  4109.     deref_args(funct,set_1);
  4110.     if(arg1->type==top)
  4111.       residuate(arg1);
  4112.     else
  4113.       if(FALSE /*arg1->type->type!=predicate*/) {
  4114.         success=FALSE;
  4115.         Errorline("argument of %P should be a predicate.\n",funct);
  4116.       }
  4117.       else {
  4118.     resid_aim=NULL;
  4119.         cutpt=choice_stack;
  4120.  
  4121.         /* Result is FALSE */
  4122.         other=stack_psi_term(0);
  4123.         other->type=false;
  4124.  
  4125.         push_choice_point(unify,result,other,NULL);
  4126.  
  4127.         /* Result is TRUE */
  4128.         other=stack_psi_term(0);
  4129.         other->type=true;
  4130.  
  4131.         push_goal(unify,result,other,NULL);
  4132.         push_goal(prove,arg1,DEFRULES,NULL);
  4133.       }
  4134.   }
  4135.   else
  4136.     curry();
  4137.  
  4138.   return success;
  4139. }
  4140.  
  4141.  
  4142.  
  4143. /******** C_BK_ASSIGN()
  4144.   This implements backtrackable assignment.
  4145. */
  4146. static long c_bk_assign()
  4147. {
  4148.   long success=FALSE;
  4149.   ptr_psi_term arg1,arg2,g;
  4150.   
  4151.   g=aim->a;
  4152.   deref_ptr(g);
  4153.   get_two_args(g->attr_list,&arg1,&arg2);
  4154.   if (arg1 && arg2) {
  4155.     success=TRUE;
  4156.     deref(arg1);
  4157.     deref_rec(arg2); /* 17.9 */
  4158.     /* deref(arg2); 17.9 */
  4159.     deref_args(g,set_1_2);
  4160.     if (arg1 != arg2) {
  4161.  
  4162.       /*  RM: Mar 10 1993  */
  4163.       if((GENERIC)arg1>=heap_pointer) {
  4164.     Errorline("cannot use '<-' on persistent value in %P\n",g);
  4165.     return c_abort();
  4166.       }
  4167.  
  4168.  
  4169. #ifdef TS
  4170.       if (!TRAIL_CONDITION(arg1)) {
  4171.         /* If no trail, then can safely overwrite the psi-term */
  4172.         release_resid_notrail(arg1);
  4173.         *arg1 = *arg2;
  4174.         push_psi_ptr_value(arg2,&(arg2->coref)); /* 14.12 */
  4175.         arg2->coref=arg1; /* 14.12 */
  4176.       }
  4177.       else {
  4178.         push_psi_ptr_value(arg1,&(arg1->coref));
  4179.         arg1->coref=arg2;
  4180.         release_resid(arg1);
  4181.       }
  4182. #else
  4183.       push_psi_ptr_value(arg1,&(arg1->coref));
  4184.       arg1->coref=arg2;
  4185.       release_resid(arg1);
  4186. #endif
  4187.     }
  4188.   }
  4189.   else
  4190.     Errorline("argument missing in %P.\n",g);
  4191.   
  4192.   return success;
  4193. }
  4194.  
  4195.  
  4196.  
  4197.  
  4198. /******** C_ASSIGN()
  4199.   This implements non-backtrackable assignment.
  4200.   It doesn't work because backtrackable unifications can have been made before
  4201.   this assignment was reached. It is complicated by the fact that the assigned
  4202.   term has to be copied into the heap as it becomes a permanent object.
  4203. */
  4204. static long c_assign()
  4205. {
  4206.   long success=FALSE;
  4207.   ptr_psi_term arg1,arg2,g,perm,smallest;
  4208.   
  4209.   g=aim->a;
  4210.   deref_ptr(g);
  4211.   get_two_args(g->attr_list,&arg1,&arg2);
  4212.   if (arg1 && arg2) {
  4213.     success=TRUE;
  4214.     deref_ptr(arg1);
  4215.     deref_rec(arg2); /* 17.9 */
  4216.     /* deref(arg2); 17.9 */
  4217.     deref_args(g,set_1_2);
  4218.     if ((GENERIC)arg1<heap_pointer || arg1!=arg2) {
  4219.       clear_copy();
  4220.       *arg1 = *exact_copy(arg2,HEAP);
  4221.     }
  4222.   }
  4223.   else
  4224.     Errorline("argument missing in %P.\n",g);
  4225.   
  4226.   return success;
  4227. }
  4228.  
  4229.  
  4230.  
  4231. /******** C_GLOBAL_ASSIGN()
  4232.   This implements non-backtrackable assignment on global variables.
  4233.  
  4234.   Closely modelled on 'c_assign', except that pointers to the heap are not
  4235.   copied again onto the heap.
  4236.   */
  4237.  
  4238. static long c_global_assign()
  4239. {
  4240.   long success=FALSE;
  4241.   ptr_psi_term arg1,arg2,g,perm,smallest;
  4242.   ptr_psi_term new;
  4243.   
  4244.   g=aim->a;
  4245.   deref_ptr(g);
  4246.   get_two_args(g->attr_list,&arg1,&arg2);
  4247.   if (arg1 && arg2) {
  4248.     success=TRUE;
  4249.     deref_rec(arg1);
  4250.     deref_rec(arg2);
  4251.     deref_args(g,set_1_2);
  4252.     if (arg1!=arg2) {
  4253.  
  4254.       clear_copy();
  4255.       new=inc_heap_copy(arg2);
  4256.       
  4257.       if((GENERIC)arg1<heap_pointer) {
  4258.     push_psi_ptr_value(arg1,&(arg1->coref));
  4259.     arg1->coref= new;
  4260.       }
  4261.       else {
  4262.     *arg1= *new; /* Overwrite in-place */
  4263.     new->coref=arg1;
  4264.       }
  4265.     }
  4266.   }
  4267.   else
  4268.     Errorline("argument missing in %P.\n",g);
  4269.   
  4270.   return success;
  4271. }
  4272.  
  4273.  
  4274.  
  4275. /******** C_UNIFY_FUNC
  4276.   An explicit unify function that curries on its two arguments.
  4277. */
  4278. static long c_unify_func()
  4279. {
  4280.   long success=TRUE;
  4281.   ptr_psi_term funct,arg1,arg2,result;
  4282.  
  4283.   funct=aim->a;
  4284.   deref_ptr(funct);
  4285.   get_two_args(funct->attr_list,&arg1,&arg2);
  4286.   if (arg1 && arg2) {
  4287.     deref(arg1);
  4288.     deref(arg2);
  4289.     deref_args(funct,set_1_2);
  4290.     result=aim->b;
  4291.     push_goal(unify,arg1,result,NULL);
  4292.     push_goal(unify,arg1,arg2,NULL);
  4293.   }
  4294.   else
  4295.     curry();
  4296.  
  4297.   return success;
  4298. }
  4299.  
  4300.  
  4301.  
  4302.  
  4303. /******** C_UNIFY_PRED()
  4304.   This unifies its two arguments (i.e. implements the predicate A=B).
  4305. */
  4306. static long c_unify_pred()
  4307. {
  4308.   long success=FALSE;
  4309.   ptr_psi_term arg1,arg2,g;
  4310.   
  4311.   g=aim->a;
  4312.   deref_ptr(g);
  4313.   get_two_args(g->attr_list,&arg1,&arg2);
  4314.   if (arg1 && arg2) {
  4315.     deref_args(g,set_1_2);
  4316.     success=TRUE;
  4317.     push_goal(unify,arg1,arg2,NULL);
  4318.   }
  4319.   else
  4320.     Errorline("argument missing in %P.\n",g);
  4321.   
  4322.   return success;
  4323. }
  4324.  
  4325.  
  4326.  
  4327.  
  4328. /******** C_COPY_POINTER
  4329.   Make a fresh copy of the input's sort, keeping exactly the same
  4330.   arguments as before (i.e., copying the sort and feature table but not
  4331.   the feature values).
  4332. */
  4333. static long c_copy_pointer()   /*  PVR: Dec 17 1992  */
  4334. {
  4335.   long success=TRUE;
  4336.   ptr_psi_term funct,arg1,result,other;
  4337.  
  4338.   funct=aim->a;
  4339.   deref_ptr(funct);
  4340.   get_one_arg(funct->attr_list,&arg1);
  4341.   if (arg1) {
  4342.     deref(arg1);
  4343.     deref_args(funct,set_1);
  4344.     other=stack_psi_term(4);
  4345.     other->type=arg1->type;
  4346.     other->value=arg1->value;
  4347.     other->attr_list=copy_attr_list(arg1->attr_list); /* PVR 23.2.94 */
  4348.     result=aim->b;
  4349.     push_goal(unify,other,result,NULL);
  4350.   }
  4351.   else
  4352.     curry();
  4353.  
  4354.   return success;
  4355. }
  4356.  
  4357.  
  4358.  
  4359. /******** C_COPY_TERM
  4360.   Make a fresh copy of the input argument, keeping its structure
  4361.   but with no connections to the input.
  4362. */
  4363. static long c_copy_term()
  4364. {
  4365.   long success=TRUE;
  4366.   ptr_psi_term funct,arg1,copy_arg1,result;
  4367.  
  4368.   funct=aim->a;
  4369.   deref_ptr(funct);
  4370.   get_one_arg(funct->attr_list,&arg1);
  4371.   if (arg1) {
  4372.     deref(arg1);
  4373.     deref_args(funct,set_1);
  4374.     result=aim->b;
  4375.     clear_copy();
  4376.     copy_arg1=exact_copy(arg1,STACK);
  4377.     push_goal(unify,copy_arg1,result,NULL);
  4378.   }
  4379.   else
  4380.     curry();
  4381.  
  4382.   return success;
  4383. }
  4384.  
  4385.  
  4386.  
  4387.  
  4388. /******** C_UNDO
  4389.   This will prove a goal on backtracking.
  4390.   This is a completely uninteresting implmentation which is equivalent to:
  4391.  
  4392.   undo.
  4393.   undo(G) :- G.
  4394.  
  4395.   The problem is that it can be affected by CUT.
  4396.   A correct implementation would be very simple:
  4397.   stack the pair (ADDRESS=NULL, VALUE=GOAL) onto the trail and when undoing
  4398.   push the goal onto the goal-stack.
  4399. */
  4400. static long c_undo()
  4401. {
  4402.   long success=TRUE;
  4403.   ptr_psi_term arg1,arg2,g;
  4404.   
  4405.   g=aim->a;
  4406.   deref_ptr(g);
  4407.   get_two_args(g->attr_list,&arg1,&arg2);
  4408.   if (arg1) {
  4409.     deref_args(g,set_1);
  4410.     push_choice_point(prove,arg1,DEFRULES,NULL);
  4411.   }
  4412.   else {
  4413.     success=FALSE;
  4414.     Errorline("argument missing in %P.\n",g);
  4415.   }
  4416.   
  4417.   return success;
  4418. }
  4419.  
  4420.  
  4421.  
  4422.  
  4423. /******** C_FREEZE_INNER
  4424.   This implements the freeze and implies predicates.
  4425.   For example:
  4426.  
  4427.     freeze(g)
  4428.  
  4429.   The proof will use matching on the heads of g's definition rather than
  4430.   unification to prove Goal.  An implicit cut is put at the beginning
  4431.   of each clause body.  Body goals are executed in the same way as
  4432.   without freeze.  Essentially, the predicate is called as if it were
  4433.   a function.
  4434.  
  4435.     implies(g)
  4436.  
  4437.   The proof will use matching as for freeze, but there is no cut at the
  4438.   beginning of the clause body & no residuation is done (the clause
  4439.   fails if its head is not implied by the caller).  Essentially, the
  4440.   predicate is called as before except that matching is used instead
  4441.   of unification to decide whether to enter a clause.
  4442. */
  4443. static long c_freeze_inner(freeze_flag)
  4444. long freeze_flag;
  4445. {
  4446.   long success=TRUE;
  4447.   ptr_psi_term arg1,g;
  4448.   ptr_psi_term head, body;
  4449.   ptr_pair_list rule;
  4450.   /* RESID */ ptr_resid_block rb;
  4451.   ptr_choice_point cutpt;
  4452.   ptr_psi_term match_date;
  4453.   
  4454.   g=aim->a;
  4455.   deref_ptr(g);
  4456.   get_one_arg(g->attr_list,&arg1);
  4457.   
  4458.   if (arg1) {
  4459.     deref_ptr(arg1);
  4460.     /* if (!arg1->type->evaluate_args) mark_quote(arg1); 8.9 */ /* 18.2 PVR */
  4461.     deref_args(g,set_1);
  4462.     deref_ptr(arg1);
  4463.     
  4464.     if (arg1->type->type!=predicate) {
  4465.       success=FALSE;
  4466.       Errorline("the argument %P of freeze must be a predicate.\n",arg1);
  4467.       /* main_loop_ok=FALSE; 8.9 */
  4468.       return success;
  4469.     }
  4470.     resid_aim=aim;
  4471.     match_date=(ptr_psi_term)stack_pointer;
  4472.     cutpt=choice_stack; /* 13.6 */
  4473.     /* Third argument of freeze's aim is used to keep track of which */
  4474.     /* clause is being tried in the frozen goal. */
  4475.     rule=(ptr_pair_list)aim->c; /* 8.9 */ /* Isn't aim->c always NULL? */
  4476.     resid_vars=NULL;
  4477.     curried=FALSE;
  4478.     can_curry=TRUE; /* 8.9 */
  4479.  
  4480.     if (!rule) rule=arg1->type->rule; /* 8.9 */
  4481.     /* if ((unsigned long)rule==DEFRULES) rule=arg1->type->rule; 8.9 */
  4482.  
  4483.     if (rule) {
  4484.       Traceline("evaluate frozen predicate %P\n",g);
  4485.       /* resid_limit=(ptr_goal )stack_pointer; 12.6 */
  4486.       
  4487.       if ((unsigned long)rule<=MAX_BUILT_INS) {
  4488.         success=FALSE; /* 8.9 */
  4489.         Errorline("the argument %P of freeze must be user-defined.\n",arg1); /* 8.9 */
  4490.         return success; /* 8.9 */
  4491.     /* Removed obsolete stuff here 11.9 */
  4492.       }
  4493.       else {
  4494.         while (rule && (rule->a==NULL || rule->b==NULL)) {
  4495.           rule=rule->next;
  4496.       Traceline("alternative clause has been retracted\n");
  4497.         }
  4498.         if (rule) {
  4499.           /* RESID */ rb = STACK_ALLOC(resid_block);
  4500.           /* RESID */ save_resid(rb,match_date);
  4501.           /* RESID */ /* resid_aim = NULL; */
  4502.  
  4503.       clear_copy();
  4504.           if (TRUE /*arg1->type->evaluate_args 8.9 */)
  4505.         head=eval_copy(rule->a,STACK);
  4506.           else
  4507.         head=quote_copy(rule->a,STACK);
  4508.       body=eval_copy(rule->b,STACK);
  4509.       head->status=4;
  4510.  
  4511.       if (rule->next)
  4512.         /* push_choice_point(prove,g,rule->next,NULL); 8.9 */
  4513.         push_choice_point(prove,g,DEFRULES,rule->next);
  4514.     
  4515.       push_goal(prove,body,DEFRULES,NULL);
  4516.       if (freeze_flag) /* 12.10 */
  4517.         push_goal(freeze_cut,body,cutpt,rb); /* 13.6 */
  4518.       else
  4519.         push_goal(implies_cut,body,cutpt,rb);
  4520.       /* RESID */ push_goal(match,arg1,head,rb);
  4521.       /* eval_args(head->attr_list); */
  4522.         }
  4523.         else {
  4524.           success=FALSE;
  4525.           /* resid_aim=NULL; */
  4526.         }
  4527.       }
  4528.     }
  4529.     else {
  4530.       success=FALSE;
  4531.       /* resid_aim=NULL; */
  4532.     }
  4533.     resid_aim=NULL;
  4534.     resid_vars=NULL; /* 22.9 */
  4535.   }
  4536.   else {
  4537.     success=FALSE;
  4538.     Errorline("goal missing in %P.\n",g);
  4539.   }
  4540.   
  4541.   /* match_date=NULL; */ /* 13.6 */
  4542.   return success;
  4543. }
  4544.  
  4545.  
  4546. /******** C_FREEZE()
  4547.   See c_freeze_inner.
  4548. */
  4549. static long c_freeze()
  4550. {
  4551.   return c_freeze_inner(TRUE);
  4552. }
  4553.  
  4554.  
  4555. /******** C_IMPLIES()
  4556.   See c_freeze_inner.
  4557. */
  4558. static long c_implies()
  4559. {
  4560.   return c_freeze_inner(FALSE);
  4561. }
  4562.  
  4563.  
  4564. /*  RM: May  6 1993  Changed C_CHAR to return a string */
  4565.  
  4566. /******** C_CHAR
  4567.   Create a 1 character string from an ASCII code.
  4568. */
  4569. static long c_char()
  4570.  
  4571.  
  4572. {
  4573.   long success=TRUE;
  4574.   ptr_psi_term arg1,arg2,funct,result;
  4575.   long smaller;
  4576.   long num1;
  4577.   REAL val1;
  4578.   char *str;
  4579.   
  4580.   funct=aim->a;
  4581.   deref_ptr(funct);
  4582.   result=aim->b;
  4583.   deref(result);
  4584.  
  4585.   get_two_args(funct->attr_list,&arg1,&arg2);
  4586.   if (arg1) {
  4587.     deref(arg1);
  4588.     deref_args(funct,set_1);
  4589.     if (overlap_type(arg1->type,integer)) {
  4590.       if (arg1->value) {
  4591.         ptr_psi_term t;
  4592.  
  4593.         t=stack_psi_term(4);
  4594.     t->type=quoted_string;
  4595.     str=(char *)heap_alloc(2);
  4596.         str[0] = (unsigned char) floor(*(REAL *) arg1->value);
  4597.     str[1] = 0;
  4598.     t->value=(GENERIC)str;
  4599.  
  4600.         push_goal(unify,t,result,NULL);
  4601.       }
  4602.       else
  4603.         residuate(arg1);
  4604.     }
  4605.     else {
  4606.       Errorline("argument of %P must be an integer.\n",funct);
  4607.       success=FALSE;
  4608.     }
  4609.   }
  4610.   else
  4611.     curry();
  4612.   
  4613.   return success;
  4614. }
  4615.  
  4616.  
  4617.  
  4618.  
  4619. /******** C_ASCII
  4620.   Return the Ascii code of the first character of a string or of a
  4621.   psi-term's name.
  4622. */
  4623. static long c_ascii()
  4624. {
  4625.   long success=TRUE;
  4626.   ptr_psi_term arg1,arg2,funct,result;
  4627.   long smaller;
  4628.   long num1;
  4629.   REAL val1;
  4630.   
  4631.   funct=aim->a;
  4632.   deref_ptr(funct);
  4633.   result=aim->b;
  4634.   deref(result);
  4635.  
  4636.   /* success=get_real_value(result,&val1,&num1); */
  4637.   /* if (success) { */
  4638.     get_two_args(funct->attr_list,&arg1,&arg2);
  4639.     if (arg1) {
  4640.       deref(arg1);
  4641.       deref_args(funct,set_1);
  4642.       success=matches(arg1->type,quoted_string,&smaller);
  4643.       if (success) {
  4644.     if (arg1->value) {
  4645.       unify_real_result(result,(REAL)(*((unsigned char *)arg1->value)));
  4646.     }
  4647.     else
  4648.       residuate(arg1);
  4649.       }
  4650.       else {/*  RM: Feb 18 1994  */
  4651.     success=FALSE;
  4652.     Errorline("String argument expected in '%P'\n",funct);
  4653.       }
  4654.       /*
  4655.       else {
  4656.         success=TRUE;
  4657.         unify_real_result(result,(REAL)(*((unsigned char *)arg1->type->keyword->symbol)));
  4658.     }
  4659.     */
  4660.     }
  4661.     else
  4662.       curry();
  4663.   /* } */
  4664.   
  4665.   return success;
  4666. }
  4667.  
  4668.  
  4669.  
  4670. /******** C_STRING2PSI(P)
  4671.   Convert a string to a psi-term whose name is the string's value.
  4672. */
  4673. static long c_string2psi()
  4674. {
  4675.   long success=TRUE;
  4676.   ptr_psi_term arg1,arg2,arg3,funct,result,t;
  4677.   long smaller;
  4678.   ptr_module mod=NULL; /*  RM: Mar 11 1993  */
  4679.   ptr_module save_current; /*  RM: Mar 12 1993  */
  4680.   
  4681.   
  4682.   funct=aim->a;
  4683.   deref_ptr(funct);
  4684.   result=aim->b;
  4685.   deref(result);
  4686.  
  4687.   get_two_args(funct->attr_list,&arg1,&arg2);
  4688.   if(arg1)
  4689.     deref(arg1);
  4690.   if(arg2)
  4691.     deref(arg2);
  4692.   deref_args(funct,set_1_2);
  4693.   
  4694.   if (arg1) {
  4695.     success=overlap_type(arg1->type,quoted_string);
  4696.     if(success) {
  4697.       
  4698.       /*  RM: Mar 11 1993  */
  4699.       if(arg2)
  4700.     success=get_module(arg2,&mod);
  4701.       
  4702.       if (success) {
  4703.     if(!arg1->value)
  4704.       residuate(arg1);
  4705.     else {
  4706.       t=stack_psi_term(4);
  4707.       save_current=current_module;
  4708.       if(mod)
  4709.         current_module=mod;
  4710.       t->type=update_symbol(mod,(char *)arg1->value);
  4711.       current_module=save_current;
  4712.       if(t->type==error_psi_term->type)
  4713.         success=FALSE;
  4714.       else
  4715.         push_goal(unify,t,result,NULL);
  4716.     }
  4717.       }
  4718.     }
  4719.     else {
  4720.       success=FALSE;
  4721.       Warningline("argument of '%P' is not a string.\n",funct);
  4722.       /* report_warning(funct,"argument is not a string"); 9.9 */
  4723.     }
  4724.   }
  4725.   else
  4726.     curry();
  4727.  
  4728.   if(!success)
  4729.     Errorline("error occurred in '%P'\n",funct);
  4730.   
  4731.   return success;
  4732. }
  4733.  
  4734.  
  4735.  
  4736. /******** C_PSI2STRING(P)
  4737.   Convert a psi-term's name into a string with the name as value.
  4738. */
  4739. static long c_psi2string()
  4740. {
  4741.   long success=TRUE;
  4742.   ptr_psi_term arg1,arg3,funct,result,t;
  4743.   char buf[100]; /*  RM: Mar 10 1993  */
  4744.   
  4745.   funct=aim->a;
  4746.   deref_ptr(funct);
  4747.   result=aim->b;
  4748.   deref(result);
  4749.  
  4750.   get_one_arg(funct->attr_list,&arg1);
  4751.   if (arg1) {
  4752.     deref(arg1);
  4753.     deref_args(funct,set_1);
  4754.     t=stack_psi_term(0);
  4755.     t->type=quoted_string;
  4756.  
  4757.     /*  RM: Mar 10 1993  */
  4758.     if(arg1->value && sub_type(arg1->type,real)) {
  4759.       sprintf(buf,"%g", *((double *)(arg1->value)));
  4760.       t->value=(GENERIC)heap_copy_string(buf);
  4761.     }
  4762.     else
  4763.       if(arg1->value && sub_type(arg1->type,quoted_string)) {
  4764.     t->value=(GENERIC)heap_copy_string((char *)arg1->value);
  4765.       }
  4766.       else
  4767.     t->value=(GENERIC)heap_copy_string(arg1->type->keyword->symbol);
  4768.     
  4769.     push_goal(unify,t,result,NULL);
  4770.   }
  4771.   else
  4772.     curry();
  4773.  
  4774.   return success;
  4775. }
  4776.  
  4777.  
  4778.  
  4779. /******** C_INT2STRING(P)
  4780.   Convert an integer psi-term into a string representing its value.
  4781. */
  4782. static long c_int2string()
  4783. {
  4784.   char val[STRLEN]; /* Big enough for a _long_ number */
  4785.   long success=TRUE,i;
  4786.   ptr_psi_term arg1,arg3,funct,result,t;
  4787.   REAL the_int,next,neg;
  4788.  
  4789.   funct=aim->a;
  4790.   deref_ptr(funct);
  4791.   result=aim->b;
  4792.   deref(result);
  4793.  
  4794.   get_one_arg(funct->attr_list,&arg1);
  4795.   if (arg1) {
  4796.     deref(arg1);
  4797.     deref_args(funct,set_1);
  4798.     if (overlap_type(arg1->type,integer)) {
  4799.       if (arg1->value) {
  4800.         the_int = *(REAL *)arg1->value;
  4801.  
  4802.         if (the_int!=floor(the_int)) return FALSE;
  4803.  
  4804.         neg = (the_int<0.0);
  4805.         if (neg) the_int = -the_int;
  4806.         i=STRLEN;
  4807.         i--;
  4808.         val[i]=0;
  4809.         do {
  4810.           i--;
  4811.           if (i<=0) {
  4812.             Errorline("internal buffer too small for int2str(%P).\n",arg1);
  4813.             return FALSE;
  4814.           }
  4815.           next = floor(the_int/10);
  4816.           val[i]= '0' + (unsigned long) (the_int-next*10);
  4817.           the_int = next;
  4818.         } while (the_int);
  4819.  
  4820.         if (neg) { i--; val[i]='-'; }
  4821.         t=stack_psi_term(0);
  4822.         t->type=quoted_string;
  4823.         t->value=(GENERIC)heap_copy_string(&val[i]);
  4824.         push_goal(unify,t,result,NULL);
  4825.       }
  4826.       else
  4827.         residuate(arg1);
  4828.     }
  4829.     else
  4830.       success=FALSE;
  4831.   }
  4832.   else
  4833.     curry();
  4834.  
  4835.   return success;
  4836. }
  4837.  
  4838.  
  4839.  
  4840. /******** C_SUCH_THAT
  4841.   This implements 'Value | Goal'.
  4842.   First it unifies Value with the result, then it proves Goal.
  4843.  
  4844.   This routine is different than the straight-forward implementation in Life
  4845.   which would have been: "V|G => cond(G,V,{})" because
  4846.   V is evaluated and unified before G is proved.
  4847. */
  4848. static long c_such_that()
  4849. {
  4850.   long success=TRUE;
  4851.   ptr_psi_term arg1,arg2,funct,result;
  4852.   
  4853.   funct=aim->a;
  4854.   deref_ptr(funct);
  4855.   result=aim->b;
  4856.   get_two_args(funct->attr_list,&arg1,&arg2);
  4857.   if (arg1 && arg2) {
  4858.     deref_ptr(arg1);
  4859.     deref_ptr(arg2);
  4860.     deref_args(funct,set_1_2);
  4861.     resid_aim=NULL;
  4862.     push_goal(prove,arg2,DEFRULES,NULL);
  4863.     push_goal(unify,arg1,result,NULL);
  4864.     i_check_out(arg1);
  4865.   }
  4866.   else
  4867.     curry();
  4868.   
  4869.   return success;
  4870. }
  4871.  
  4872.  
  4873.  
  4874. /* Return an attr_list with one argument */
  4875. ptr_node one_attr()
  4876. {
  4877.    ptr_node n;
  4878.  
  4879.    n = STACK_ALLOC(node);
  4880.    n->key = one;
  4881.    n->data = NULL; /* To be filled in later */
  4882.    n->left = NULL;
  4883.    n->right = NULL;
  4884.  
  4885.    return n;
  4886. }
  4887.  
  4888.  
  4889. /* Return a psi term with one or two args, and the addresses of the args */
  4890. ptr_psi_term new_psi_term(numargs, typ, a1, a2)
  4891. long numargs;
  4892. ptr_definition typ;
  4893. ptr_psi_term **a1, **a2;
  4894. {
  4895.    ptr_psi_term t;
  4896.    ptr_node n1, n2;
  4897.  
  4898.    if (numargs==2) {
  4899.      n2 = STACK_ALLOC(node);
  4900.      n2->key = two;
  4901.      *a2 = (ptr_psi_term *) &(n2->data);
  4902.      n2->left = NULL;
  4903.      n2->right = NULL;
  4904.    }
  4905.    else
  4906.      n2=NULL;
  4907.  
  4908.    n1 = STACK_ALLOC(node);
  4909.    n1->key = one;
  4910.    *a1 = (ptr_psi_term *) &(n1->data);
  4911.    n1->left = NULL;
  4912.    n1->right = n2;
  4913.  
  4914.    t=stack_psi_term(4);
  4915.    t->type = typ;
  4916.    t->attr_list = n1;
  4917.  
  4918.    return t;
  4919. }
  4920.  
  4921.  
  4922. /* Return TRUE iff there are some rules r */
  4923. /* This is true for a user-defined function or predicate with a definition, */
  4924. /* and for a type with constraints. */
  4925. long has_rules(r)
  4926. ptr_pair_list r;
  4927. {
  4928.   if (r==NULL) return FALSE;
  4929.   while (r) {
  4930.     if (r->a!=NULL) return TRUE;
  4931.     r=r->next;
  4932.   }
  4933.   return FALSE;
  4934. }
  4935.  
  4936. /* Return TRUE if rules r are for a built-in */
  4937. long is_built_in(r)
  4938. ptr_pair_list r;
  4939. {
  4940.   return ((unsigned long)r>0 && (unsigned long)r<MAX_BUILT_INS);
  4941. }
  4942.  
  4943.  
  4944. /* List the characteristics (delay_check, dynamic/static, non_strict) */
  4945. /* in such a way that they can be immediately read in. */
  4946. list_special(t)
  4947. ptr_psi_term t;
  4948. {
  4949.   ptr_definition d = t->type;
  4950.   ptr_pair_list r = t->type->rule;
  4951.   long prflag=FALSE;
  4952.  
  4953.   if (t->type->type==type) {
  4954.     if (!d->always_check) {
  4955.       if (is_built_in(r)) fprintf(output_stream,"%% ");
  4956.       fprintf(output_stream,"delay_check(");
  4957.       display_psi_stream(t);
  4958.       fprintf(output_stream,")?\n");
  4959.       prflag=TRUE;
  4960.     }
  4961.   } else {
  4962.     if (!d->protected) {
  4963.       if (is_built_in(r)) fprintf(output_stream,"%% ");
  4964.       fprintf(output_stream,"%s(",(d->protected?"static":"dynamic"));
  4965.       display_psi_stream(t);
  4966.       fprintf(output_stream,")?\n");
  4967.       prflag=TRUE;
  4968.     } 
  4969.   }
  4970.   if (!d->evaluate_args) {
  4971.     if (is_built_in(r)) fprintf(output_stream,"%% ");
  4972.     fprintf(output_stream,"non_strict(");
  4973.     display_psi_stream(t);
  4974.     fprintf(output_stream,")?\n");
  4975.     prflag=TRUE;
  4976.   }
  4977.   /* if (prflag) fprintf(output_stream,"\n"); */
  4978. }
  4979.  
  4980.  
  4981. /******** C_LISTING
  4982.   List the definition of a predicate or a function, and the own constraints
  4983.   of a type (i.e. the non-inherited constraints).
  4984. */
  4985. static long c_listing()
  4986. {
  4987.   long success=TRUE;
  4988.   ptr_psi_term arg1,arg2,g;
  4989.   def_type fp;
  4990.   ptr_pair_list r;
  4991.   ptr_node n;
  4992.   ptr_psi_term t, t2, *a1, *a2, *a3;
  4993.   char *s1,*s2;
  4994.   
  4995.   g=aim->a;
  4996.   deref_ptr(g);
  4997.   get_two_args(g->attr_list,&arg1,&arg2);
  4998.   if (arg1) {
  4999.     deref_ptr(arg1);
  5000.     list_special(arg1);
  5001.     fp=arg1->type->type;
  5002.     r=arg1->type->rule;
  5003.     if (is_built_in(r) || !has_rules(r)) {
  5004.  
  5005.       if (is_built_in(r)) {
  5006.         s1="built-in ";
  5007.         s2="";
  5008.       }
  5009.       else {
  5010.         s1="user-defined ";
  5011.         s2=" with an empty definition";
  5012.       }
  5013.       switch (fp) {
  5014.       case function:
  5015.         fprintf(output_stream,"%% '%s' is a %sfunction%s.\n",
  5016.                 arg1->type->keyword->symbol,s1,s2);
  5017.         break;
  5018.       case predicate:
  5019.         fprintf(output_stream,"%% '%s' is a %spredicate%s.\n",
  5020.                 arg1->type->keyword->symbol,s1,s2);
  5021.         break;
  5022.       case type:
  5023.         if (arg1->value) {
  5024.           fprintf(output_stream,"%% ");
  5025.           if (arg1->type!=quoted_string) fprintf(output_stream,"'");
  5026.           display_psi_stream(arg1);
  5027.           if (arg1->type!=quoted_string) fprintf(output_stream,"'");
  5028.           fprintf(output_stream," is a value of sort '%s'.\n",
  5029.                   arg1->type->keyword->symbol);
  5030.         }
  5031.         break;
  5032.  
  5033.       case global: /*  RM: Feb  9 1993  */
  5034.     fprintf(output_stream,"%% ");
  5035.     outputline("'%s' is a %sglobal variable worth %P.\n",
  5036.            arg1->type->keyword->symbol,
  5037.            s1,
  5038.            arg1->type->global_value);
  5039.         break;
  5040.  
  5041. #ifdef CLIFE
  5042.       case block: /* AA: Mar 10 1993 */
  5043.         fprintf(output_stream,"%% '%s' is a %block.\n",
  5044.                 arg1->type->keyword->symbol,"","");    
  5045. #endif
  5046.     
  5047.       default:
  5048.         fprintf(output_stream,"%% '%s' is undefined.\n", arg1->type->keyword->symbol);
  5049.       }
  5050.     }
  5051.     else {
  5052.       if (fp==type || fp==function || fp==predicate) {
  5053.         n = one_attr();
  5054.         if (fp==function)
  5055.           t = new_psi_term(2, funcsym, &a1, &a2);
  5056.         else if (fp==predicate)
  5057.           t = new_psi_term(2, predsym, &a1, &a2);
  5058.         else { /* fp==type */
  5059.           t = new_psi_term(1, typesym, &a3, &a2); /* a2 is a dummy */
  5060.           t2 = new_psi_term(2, such_that, &a1, &a2);
  5061.         }
  5062.         n->data = (GENERIC) t;
  5063.         while (r) {
  5064.           *a1 = r->a; /* Func, pred, or type */
  5065.           *a2 = r->b;
  5066.           if (r->a) {
  5067.             /* Handle an attribute constraint with no predicate: */
  5068.             if (fp==type) { if (r->b==NULL) *a3 = r->a; else *a3 = t2; }
  5069.             listing_pred_write(n, (fp==function)||(fp==type));
  5070.             fprintf(output_stream,".\n");
  5071.           }
  5072.           r = r->next;
  5073.         }
  5074.         /* fprintf(output_stream,"\n"); */
  5075.         /* fflush(output_stream); */
  5076.       }
  5077.       else {
  5078.         success=FALSE;
  5079.         Errorline("argument of %P must be a predicate, function, or sort.\n",g);
  5080.       }
  5081.     }
  5082.   }
  5083.   else {
  5084.     success=FALSE;
  5085.     Errorline("argument missing in %P.\n",g);
  5086.   }
  5087.   
  5088.   return success;
  5089. }
  5090.  
  5091.  
  5092.  
  5093. /******** C_print_codes
  5094.   Print the codes of all the sorts.
  5095. */
  5096. static long c_print_codes()
  5097. {
  5098.   ptr_psi_term t;
  5099.  
  5100.   t=aim->a;
  5101.   deref_args(t,set_empty);
  5102.   outputline("There are %d sorts.\n",type_count);
  5103.   print_codes();
  5104.   return TRUE;
  5105. }
  5106.  
  5107.  
  5108.  
  5109. /*********************** TEMPLATES FOR NEW PREDICATES AND FUNCTIONS  *******/
  5110.  
  5111.  
  5112.  
  5113. /******** C_PRED
  5114.   Template for C built-in predicates.
  5115. */
  5116. static long c_pred()
  5117. {
  5118.   long success=TRUE;
  5119.   ptr_psi_term arg1,arg2,g;
  5120.   
  5121.   g=aim->a;
  5122.   deref_ptr(g);
  5123.   get_two_args(g->attr_list,&arg1,&arg2);
  5124.   if (arg1 && arg2) {
  5125.     deref_args(g,set_1_2);
  5126.   }
  5127.   else {
  5128.     success=FALSE;
  5129.     Errorline("argument(s) missing in %P.\n",g);
  5130.   }
  5131.   
  5132.   return success;
  5133. }
  5134.  
  5135.  
  5136.  
  5137. /******** C_FUNCT
  5138.   Template for C built-in functions.
  5139. */
  5140. static long c_funct()
  5141. {
  5142.   long success=TRUE;
  5143.   ptr_psi_term arg1,arg2,funct;
  5144.  
  5145.   
  5146.   funct=aim->a;
  5147.   deref_ptr(funct);
  5148.  
  5149.   get_two_args(funct->attr_list,&arg1,&arg2);
  5150.  
  5151.   if (arg1 && arg2) {
  5152.     deref_args(funct,set_1_2);
  5153.   }
  5154.   else
  5155.     curry();
  5156.   
  5157.   return success;
  5158. }
  5159.  
  5160.  
  5161.  
  5162. /******************************************************************************
  5163.   
  5164.   Here are the routines which allow a new built_in type, predicate or function
  5165.   to be declared.
  5166.   
  5167.   ****************************************************************************/
  5168.  
  5169.  
  5170.  
  5171. /******** NEW_BUILT_IN(m,s,t,r)
  5172.   Add a new built-in predicate or function.
  5173.   Used also in x_pred.c
  5174.  
  5175.   M=module.
  5176.   S=string.
  5177.   T=type (function or predicate).
  5178.   R=address of C routine to call.
  5179. */
  5180. void new_built_in(m,s,t,r)
  5181.      ptr_module m;
  5182.      char *s;
  5183.      def_type t;
  5184.      long (*r)();
  5185. {
  5186.   ptr_definition d;
  5187.  
  5188.   if (built_in_index >= MAX_BUILT_INS) {
  5189.     fprintf(stderr,"Too many primitives, increase MAX_BUILT_INS in extern.h\n");
  5190.     exit(-1);
  5191.   }
  5192.  
  5193.   if(m!=current_module)  /*  RM: Jan 13 1993  */
  5194.     set_current_module(m);
  5195.   
  5196.   d=update_symbol(m,s); /* RM: Jan  8 1993 */
  5197.   d->type=t;
  5198.   built_in_index++;
  5199.   d->rule=(ptr_pair_list )built_in_index;
  5200.   c_rule[built_in_index]=r;
  5201. }
  5202.  
  5203.  
  5204.  
  5205. /******** OP_DECLARE(p,t,s)
  5206.   Declare that string S is an operator of precedence P and of type T where
  5207.   T=xf, fx, yf, fy, xfx etc...
  5208. */
  5209. static void op_declare(p,t,s)
  5210. long p;
  5211. operator t;
  5212. char *s;
  5213. {
  5214.   ptr_definition d;
  5215.   ptr_operator_data od;
  5216.   
  5217.   if (p>MAX_PRECEDENCE || p<0) {
  5218.     Errorline("operator precedence must be in the range 0..%d.\n",
  5219.           MAX_PRECEDENCE);
  5220.     return;
  5221.   }
  5222.   d=update_symbol(NULL,s);
  5223.  
  5224.   od= (ptr_operator_data) heap_alloc (sizeof(operator_data));
  5225.   /* od= (ptr_operator_data) malloc (sizeof(operator_data)); 12.6 */
  5226.     
  5227.   od->precedence=p;
  5228.   od->type=t;
  5229.   od->next=d->op_data;
  5230.   d->op_data=od;
  5231. }
  5232.  
  5233.  
  5234.  
  5235. /******** DECLARE_OPERATOR(t)
  5236.   Declare a new operator or change a pre-existing one.
  5237.  
  5238.   For example: '*op*'(3,xfx,+)?
  5239.   T is the OP declaration.
  5240. */
  5241. long declare_operator(t)
  5242. ptr_psi_term t;
  5243. {
  5244.   ptr_psi_term prec,type,atom;
  5245.   ptr_node n;
  5246.   char *s;
  5247.   long p;
  5248.   operator kind=nop;
  5249.   long success=FALSE;
  5250.  
  5251.   deref_ptr(t);
  5252.   n=t->attr_list;
  5253.   get_two_args(n,&prec,&type);
  5254.   n=find(featcmp,three,n);
  5255.   if (n && prec && type) {
  5256.     atom=(ptr_psi_term )n->data;
  5257.     deref_ptr(prec);
  5258.     deref_ptr(type);
  5259.     deref_ptr(atom);
  5260.     if (!atom->value) {
  5261.       s=atom->type->keyword->symbol;
  5262.       if (sub_type(prec->type,integer) && prec->value) { /* 10.8 */
  5263.         p = * (REAL *)prec->value;
  5264.     if (p>0 && p<=MAX_PRECEDENCE) {
  5265.       
  5266.           if (type->type == xf_sym) kind=xf;
  5267.           else if (type->type == yf_sym) kind=yf;
  5268.           else if (type->type == fx_sym) kind=fx;
  5269.           else if (type->type == fy_sym) kind=fy;
  5270.           else if (type->type == xfx_sym) kind=xfx;
  5271.           else if (type->type == xfy_sym) kind=xfy;
  5272.           else if (type->type == yfx_sym) kind=yfx;
  5273.           else
  5274.             Errorline("bad operator kind '%s'.\n",type->type->keyword->symbol);
  5275.     
  5276.           if (kind!=nop) {
  5277.         op_declare(p,kind,s);
  5278.         success=TRUE;
  5279.       }
  5280.         }
  5281.     else
  5282.       Errorline("precedence must range from 1 to 1200 in %P.\n",t);
  5283.       }
  5284.       else
  5285.         Errorline("precedence must be a positive integer in %P.\n",t);
  5286.     }
  5287.     else
  5288.       Errorline("numbers or strings may not be operators in %P.\n",t);
  5289.   }
  5290.   else
  5291.     Errorline("argument missing in %P.\n",t);
  5292.  
  5293.   return success;
  5294. }
  5295.  
  5296.  
  5297.  
  5298. char *str_conc(s1,s2)
  5299. char *s1, *s2;
  5300. {
  5301.   char *result;
  5302.  
  5303.   result=(char *)heap_alloc(strlen(s1)+strlen(s2)+1);
  5304.   sprintf(result,"%s%s",s1,s2);
  5305.  
  5306.   return result;
  5307. }
  5308.  
  5309.  
  5310.  
  5311. char *sub_str(s,p,n)
  5312. char *s;
  5313. long p;
  5314. long n;
  5315. {
  5316.   char *result;
  5317.   long i;
  5318.   long l;
  5319.  
  5320.   l=strlen(s);
  5321.   if(p>l || p<0 || n<0)
  5322.     n=0;
  5323.   else
  5324.     if(p+n-1>l)
  5325.       n=l-p+1;
  5326.  
  5327.   result=(char *)heap_alloc(n+1);
  5328.   for(i=0;i<n;i++)
  5329.     *(result+i)= *(s+p+i-1);
  5330.  
  5331.   *(result+n)=0;
  5332.   
  5333.   return result;
  5334. }
  5335.  
  5336.  
  5337.  
  5338. long append_files(s1,s2)
  5339. char *s1, *s2;
  5340. {
  5341.   FILE *f1;
  5342.   FILE *f2;
  5343.   long result=FALSE;
  5344.   
  5345.   f1=fopen(s1,"a");
  5346.   if(f1) {
  5347.     f2=fopen(s2,"r");
  5348.     if(f2) {
  5349.       while(!feof(f2))
  5350.     fputc(fgetc(f2),f1);
  5351.       fclose(f2);
  5352.       fclose(f1);
  5353.       result=TRUE;
  5354.     }
  5355.     else
  5356.       Errorline("couldn't open \"%s\"\n",f2);
  5357.       /* printf("*** Error: couldn't open \"%s\"\n",f2); PVR 14.9.93 */
  5358.    }
  5359.   else
  5360.     Errorline("couldn't open \"%s\"\n",f1);
  5361.     /* printf("*** Error: couldn't open \"%s\"\n",f1); PVR 14.9.93 */
  5362.  
  5363.   return result;
  5364. }
  5365.  
  5366.  
  5367.  
  5368.  
  5369. /******** C_CONCATENATE
  5370.   Concatenate the strings in arguments 1 and 2.
  5371. */
  5372. long c_concatenate()
  5373. {
  5374.   ptr_psi_term result,funct,temp_result;
  5375.   ptr_node n1, n2;
  5376.   long success=TRUE;
  5377.   long all_args=TRUE;
  5378.   char * c_result;
  5379.   ptr_psi_term arg1; 
  5380.   char * c_arg1; 
  5381.   ptr_psi_term arg2; 
  5382.   char * c_arg2; 
  5383.  
  5384.   funct=aim->a;
  5385.   deref_ptr(funct);
  5386.   result=aim->b;
  5387.  
  5388.   /* Evaluate all arguments first: */
  5389.   n1=find(featcmp,one,funct->attr_list);
  5390.   if (n1) {
  5391.     arg1= (ptr_psi_term )n1->data;
  5392.     deref(arg1);
  5393.   }
  5394.   n2=find(featcmp,two,funct->attr_list);
  5395.   if (n2) {
  5396.     arg2= (ptr_psi_term )n2->data;
  5397.     deref(arg2);
  5398.   }
  5399.   deref_args(funct,set_1_2);
  5400.  
  5401.   if (success) {
  5402.     if (n1) {
  5403.        if (overlap_type(arg1->type,quoted_string)) /* 10.8 */
  5404.           if (arg1->value)
  5405.               c_arg1= (char *)arg1->value;
  5406.           else {
  5407.             residuate(arg1);
  5408.             all_args=FALSE;
  5409.           }
  5410.        else
  5411.          success=FALSE;
  5412.     }
  5413.     else {
  5414.       all_args=FALSE;
  5415.       curry();
  5416.     };
  5417.   };
  5418.  
  5419.   if (success) {
  5420.     if (n2) {
  5421.        if (overlap_type(arg2->type,quoted_string)) /* 10.8 */
  5422.           if (arg2->value)
  5423.               c_arg2= (char *)arg2->value;
  5424.           else {
  5425.             residuate(arg2);
  5426.             all_args=FALSE;
  5427.           }
  5428.        else
  5429.          success=FALSE;
  5430.     }
  5431.     else {
  5432.       all_args=FALSE;
  5433.       curry();
  5434.     }
  5435.   }
  5436.  
  5437.   if(success && all_args) {
  5438.       c_result=str_conc( c_arg1, c_arg2 );
  5439.       temp_result=stack_psi_term(0);
  5440.       temp_result->type=quoted_string;
  5441.       temp_result->value=(GENERIC) c_result;
  5442.       push_goal(unify,temp_result,result,NULL);
  5443.   }
  5444.  
  5445.   return success;
  5446. }
  5447.  
  5448.  
  5449.  
  5450. /******** C_MODULE_NAME
  5451.   Return the module in which a term resides.
  5452.   */
  5453. static long c_module_name()
  5454. {
  5455.   long success=TRUE;
  5456.   ptr_psi_term arg1,arg2,funct,result;
  5457.   
  5458.   
  5459.   funct=aim->a;
  5460.   result=aim->b;
  5461.   deref_ptr(funct);
  5462.   deref_ptr(result);
  5463.   
  5464.   get_two_args(funct->attr_list,&arg1,&arg2);
  5465.   
  5466.   if (arg1) {
  5467.     deref_ptr(arg1);
  5468.     arg2=stack_psi_term(0);
  5469.     arg2->type=quoted_string;
  5470.     arg2->value=(GENERIC)heap_copy_string(arg1->type->keyword->module->module_name);
  5471.     push_goal(unify,arg2,result,NULL);
  5472.   }
  5473.   else
  5474.     curry();
  5475.   
  5476.   return success;
  5477. }
  5478.  
  5479.  
  5480.  
  5481. /******** C_COMBINED_NAME
  5482.   Return the string module#name for a term.
  5483.   */
  5484. static long c_combined_name()
  5485. {
  5486.   long success=TRUE;
  5487.   ptr_psi_term arg1,arg2,funct,result;
  5488.   
  5489.   
  5490.   funct=aim->a;
  5491.   result=aim->b;
  5492.   deref_ptr(funct);
  5493.   deref_ptr(result);
  5494.   
  5495.   get_two_args(funct->attr_list,&arg1,&arg2);
  5496.   
  5497.   if (arg1) {
  5498.     deref_ptr(arg1);
  5499.     arg2=stack_psi_term(0);
  5500.     arg2->type=quoted_string;
  5501.     arg2->value=(GENERIC)heap_copy_string(arg1->type->keyword->combined_name);
  5502.     push_goal(unify,arg2,result,NULL);
  5503.   }
  5504.   else
  5505.     curry();
  5506.   
  5507.   return success;
  5508. }
  5509.  
  5510.  
  5511.  
  5512.  
  5513. /******** C_STRING_LENGTH
  5514.   Return the length of the string in argument 1.
  5515.   */
  5516. long c_string_length()
  5517. {
  5518.   ptr_psi_term result,funct;
  5519.   ptr_node n1;
  5520.   long success=TRUE;
  5521.   long all_args=TRUE;
  5522.   long c_result;
  5523.   ptr_psi_term arg1; 
  5524.   char * c_arg1; 
  5525.  
  5526.   funct=aim->a;
  5527.   deref_ptr(funct);
  5528.   result=aim->b;
  5529.  
  5530.   /* Evaluate all arguments first: */
  5531.   n1=find(featcmp,one,funct->attr_list);
  5532.   if (n1) {
  5533.     arg1= (ptr_psi_term )n1->data;
  5534.     deref(arg1);
  5535.   }
  5536.   deref_args(funct,set_1);
  5537.  
  5538.   if (success) {
  5539.     if (n1) {
  5540.        if (overlap_type(arg1->type,quoted_string)) /* 10.8 */
  5541.           if (arg1->value)
  5542.               c_arg1= (char *)arg1->value;
  5543.           else {
  5544.             residuate(arg1);
  5545.             all_args=FALSE;
  5546.           }
  5547.        else
  5548.          success=FALSE;
  5549.     }
  5550.     else {
  5551.       all_args=FALSE;
  5552.       curry();
  5553.     };
  5554.   };
  5555.  
  5556.   if (success && all_args) {
  5557.       c_result=strlen(c_arg1);
  5558.       push_goal(unify,real_stack_psi_term(0,(REAL)c_result),result,NULL);
  5559.   };
  5560.  
  5561. return success;
  5562. }
  5563.  
  5564.  
  5565.  
  5566.  
  5567. /******** C_SUB_STRING
  5568.   Return the substring of argument 1 from position argument 2 for a
  5569.   length of argument 3 characters.
  5570. */
  5571. long c_sub_string()
  5572. {
  5573.   ptr_psi_term result,funct,temp_result;
  5574.   ptr_node n1,n2,n3;
  5575.   long success=TRUE;
  5576.   long all_args=TRUE;
  5577.   char * c_result;
  5578.   ptr_psi_term arg1; 
  5579.   char * c_arg1; 
  5580.   ptr_psi_term arg2; 
  5581.   long c_arg2; 
  5582.   ptr_psi_term arg3; 
  5583.   long c_arg3; 
  5584.  
  5585.   funct=aim->a;
  5586.   deref_ptr(funct);
  5587.   result=aim->b;
  5588.  
  5589.   /* Evaluate all arguments first: */
  5590.   n1=find(featcmp,one,funct->attr_list);
  5591.   if (n1) {
  5592.     arg1= (ptr_psi_term )n1->data;
  5593.     deref(arg1);
  5594.   }
  5595.   n2=find(featcmp,two,funct->attr_list);
  5596.   if (n2) {
  5597.     arg2= (ptr_psi_term )n2->data;
  5598.     deref(arg2);
  5599.   }
  5600.   n3=find(featcmp,three,funct->attr_list);
  5601.   if (n3) {
  5602.     arg3= (ptr_psi_term )n3->data;
  5603.     deref(arg3);
  5604.   }
  5605.   deref_args(funct,set_1_2_3);
  5606.  
  5607.   if (success) {
  5608.     if (n1) {
  5609.        if (overlap_type(arg1->type,quoted_string)) /* 10.8 */
  5610.           if (arg1->value)
  5611.               c_arg1= (char *)arg1->value;
  5612.           else {
  5613.             residuate(arg1);
  5614.             all_args=FALSE;
  5615.           }
  5616.        else
  5617.          success=FALSE;
  5618.     }
  5619.     else {
  5620.       all_args=FALSE;
  5621.       curry();
  5622.     };
  5623.   };
  5624.  
  5625.   if (success) {
  5626.     if (n2) {
  5627.        if (overlap_type(arg2->type,integer)) /* 10.8 */
  5628.           if (arg2->value)
  5629.               c_arg2= (long)(* (double *)(arg2->value));
  5630.           else {
  5631.             residuate(arg2);
  5632.             all_args=FALSE;
  5633.           }
  5634.        else
  5635.          success=FALSE;
  5636.     }
  5637.     else {
  5638.       all_args=FALSE;
  5639.       curry();
  5640.     };
  5641.   };
  5642.  
  5643.   if (success) {
  5644.     if (n3) {
  5645.        if (overlap_type(arg3->type,integer)) /* 10.8 */
  5646.           if (arg3->value)
  5647.               c_arg3= (long)(* (double *)(arg3->value));
  5648.           else {
  5649.             residuate(arg3);
  5650.             all_args=FALSE;
  5651.           }
  5652.        else
  5653.          success=FALSE;
  5654.     }
  5655.     else {
  5656.       all_args=FALSE;
  5657.       curry();
  5658.     };
  5659.   };
  5660.  
  5661.   if (success && all_args) {
  5662.       c_result=sub_str(c_arg1,c_arg2,c_arg3);
  5663.       temp_result=stack_psi_term(0);
  5664.       temp_result->type=quoted_string;
  5665.       temp_result->value=(GENERIC) c_result;
  5666.       push_goal(unify,temp_result,result,NULL);
  5667.   };
  5668.  
  5669. return success;
  5670. }
  5671.  
  5672.  
  5673.  
  5674.  
  5675. /******** C_APPEND_FILE
  5676.   Append the file named by argument 2 to the file named by argument 1.
  5677.   This predicate will not residuate; it requires string arguments.
  5678. */
  5679. long c_append_file()
  5680. {
  5681.   ptr_psi_term g;
  5682.   ptr_node n1,n2;
  5683.   long success=TRUE;
  5684.   ptr_psi_term arg1; 
  5685.   char * c_arg1; 
  5686.   ptr_psi_term arg2; 
  5687.   char * c_arg2; 
  5688.  
  5689.   g=aim->a;
  5690.   deref_ptr(g);
  5691.  
  5692.   /* Evaluate all arguments first: */
  5693.   n1=find(featcmp,one,g->attr_list);
  5694.   if (n1) {
  5695.     arg1= (ptr_psi_term )n1->data;
  5696.     deref(arg1);
  5697.   }
  5698.   n2=find(featcmp,two,g->attr_list);
  5699.   if (n2) {
  5700.     arg2= (ptr_psi_term )n2->data;
  5701.     deref(arg2);
  5702.   }
  5703.   deref_args(g,set_1_2);
  5704.  
  5705.   if (success) {
  5706.     if (n1) {
  5707.        if (overlap_type(arg1->type,quoted_string))
  5708.           if (arg1->value)
  5709.               c_arg1= (char *)arg1->value;
  5710.           else {
  5711.             success=FALSE;
  5712.             Errorline("bad argument in %P.\n",g);
  5713.           }
  5714.        else
  5715.          success=FALSE;
  5716.     }
  5717.     else {
  5718.       success=FALSE;
  5719.       Errorline("bad argument in %P.\n",g);
  5720.     };
  5721.   };
  5722.  
  5723.   if (success) {
  5724.     if (n2) {
  5725.        if (overlap_type(arg2->type,quoted_string))
  5726.           if (arg2->value)
  5727.               c_arg2= (char *)arg2->value;
  5728.           else {
  5729.             success=FALSE;
  5730.             Errorline("bad argument in %P.\n",g);
  5731.           }
  5732.        else
  5733.          success=FALSE;
  5734.     }
  5735.     else {
  5736.       success=FALSE;
  5737.       Errorline("bad argument in %P.\n",g);
  5738.     };
  5739.   };
  5740.  
  5741.   if (success)
  5742.     success=append_files(c_arg1,c_arg2);
  5743.  
  5744. return success;
  5745. }
  5746.  
  5747.  
  5748.  
  5749. /******** C_RANDOM
  5750.   Return an integer random number between 0 and abs(argument1).
  5751.   Uses the Unix random() function (rand_r(&seed) for Solaris).
  5752. */
  5753. long c_random()
  5754. {
  5755.   ptr_psi_term result,funct;
  5756.   ptr_node n1;
  5757.   long success=TRUE;
  5758.   long all_args=TRUE;
  5759.   long c_result;
  5760.   ptr_psi_term arg1; 
  5761.   long c_arg1; 
  5762.  
  5763.   funct=aim->a;
  5764.   deref_ptr(funct);
  5765.   result=aim->b;
  5766.  
  5767.   /* Evaluate all arguments first: */
  5768.   n1=find(featcmp,one,funct->attr_list);
  5769.   if (n1) {
  5770.     arg1= (ptr_psi_term )n1->data;
  5771.     deref(arg1);
  5772.   }
  5773.   deref_args(funct,set_1);
  5774.  
  5775.   if (success) {
  5776.     if (n1) {
  5777.        if (overlap_type(arg1->type,integer))
  5778.           if (arg1->value)
  5779.               c_arg1= (long)(* (double *)(arg1->value));
  5780.           else {
  5781.             residuate(arg1);
  5782.             all_args=FALSE;
  5783.           }
  5784.        else
  5785.          success=FALSE;
  5786.     }
  5787.     else {
  5788.       all_args=FALSE;
  5789.       curry();
  5790.     }
  5791.   }
  5792.  
  5793.   if (success && all_args) {
  5794.       if (c_arg1) {
  5795. #ifdef SOLARIS
  5796.     c_result=(rand_r(&randomseed)<<15) + rand_r(&randomseed);
  5797. #else
  5798.         c_result=random();
  5799. #endif
  5800.         c_result=c_result-(c_result/c_arg1)*c_arg1;
  5801.       }
  5802.       else
  5803.         c_result=0;
  5804.  
  5805.       push_goal(unify,real_stack_psi_term(0,(REAL)c_result),result,NULL);
  5806.   }
  5807.  
  5808.   return success;
  5809. }
  5810.  
  5811.  
  5812.  
  5813. /******** C_INITRANDOM
  5814.   Uses its integer argument to initialize
  5815.   the random number generator, which is the Unix random() function.
  5816. */
  5817. long c_initrandom()
  5818. {
  5819.   ptr_psi_term t;
  5820.   ptr_node n1;
  5821.   long success=TRUE;
  5822.   long all_args=TRUE;
  5823.   long c_result;
  5824.   ptr_psi_term arg1; 
  5825.   long c_arg1; 
  5826.  
  5827.   t=aim->a;
  5828.   deref_ptr(t);
  5829.  
  5830.   /* Evaluate all arguments first: */
  5831.   n1=find(featcmp,one,t->attr_list);
  5832.   if (n1) {
  5833.     arg1= (ptr_psi_term )n1->data;
  5834.     deref(arg1);
  5835.   }
  5836.   deref_args(t,set_1);
  5837.  
  5838.   if (success) {
  5839.     if (n1) {
  5840.        if (overlap_type(arg1->type,integer))
  5841.           if (arg1->value)
  5842.               c_arg1= (long)(* (double *)(arg1->value));
  5843.           else {
  5844.             residuate(arg1);
  5845.             all_args=FALSE;
  5846.           }
  5847.        else
  5848.          success=FALSE;
  5849.     }
  5850.     else {
  5851.       all_args=FALSE;
  5852.     }
  5853.   }
  5854.  
  5855. #ifdef SOLARIS
  5856.   if (success && all_args) randomseed=c_arg1;
  5857. #else
  5858.   if (success && all_args) srandom(c_arg1);
  5859. #endif
  5860.  
  5861.   return success;
  5862. }
  5863.  
  5864.  
  5865.  
  5866. /******** C_DEREF_LENGTH
  5867.   Return the length of the dereference chain for argument 1.
  5868.   */
  5869. /*  RM: Jul 15 1993  */
  5870. long c_deref_length()
  5871. {
  5872.   ptr_psi_term result,funct;
  5873.   long success=TRUE;
  5874.   int count;
  5875.   ptr_psi_term arg1,arg2;
  5876.   ptr_node n1;
  5877.   
  5878.   funct=aim->a;
  5879.   deref_ptr(funct);
  5880.   result=aim->b;
  5881.  
  5882.   n1=find(featcmp,one,funct->attr_list);
  5883.   if (n1) {
  5884.     count=0;
  5885.     arg1= (ptr_psi_term )n1->data;
  5886.     while(arg1->coref) {
  5887.       count++;
  5888.       arg1=arg1->coref;
  5889.     }
  5890.     success=unify_real_result(result,(REAL)count);
  5891.   }
  5892.   else
  5893.     curry();
  5894.   
  5895.   return success;
  5896. }
  5897.  
  5898.  
  5899.  
  5900. /******** C_ARGS
  5901.   Return the Unix "ARGV" array as a list of strings.
  5902.   */
  5903. /*  RM: Sep 20 1993  */
  5904. long c_args()
  5905. {
  5906.   ptr_psi_term result,list,str;
  5907.   long success=TRUE;
  5908.   int i;
  5909.  
  5910.   result=aim->b;
  5911.   
  5912.   list=stack_nil();
  5913.   for(i=arg_c-1;i>=0;i--) {
  5914.     str=stack_psi_term(0);
  5915.     str->type=quoted_string;
  5916.     str->value=(GENERIC)heap_copy_string(arg_v[i]);
  5917.     list=stack_cons(str,list);
  5918.   }
  5919.   push_goal(unify,result,list,NULL);
  5920.   
  5921.   return success;
  5922. }
  5923.  
  5924. /******** INIT_BUILT_IN_TYPES
  5925.   Initialise the symbol tree with the built-in types.
  5926.   Declare all built-in predicates and functions.
  5927.   Initialise system type variables.
  5928.   Declare all standard operators.
  5929.  
  5930.   Called by life.c
  5931. */
  5932. void init_built_in_types()
  5933. {
  5934.   ptr_definition t;
  5935.   
  5936.   /* symbol_table=NULL;   RM: Feb  3 1993  */
  5937.  
  5938.   
  5939.   
  5940.   /*  RM: Jan 13 1993  */
  5941.   /* Initialize the minimum syntactic symbols */
  5942.   set_current_module(syntax_module); /*  RM: Feb  3 1993  */
  5943.   and=update_symbol(syntax_module,",");  
  5944.   update_symbol(syntax_module,"[");
  5945.   update_symbol(syntax_module,"]");
  5946.   update_symbol(syntax_module,"(");
  5947.   update_symbol(syntax_module,")");
  5948.   update_symbol(syntax_module,"{");
  5949.   update_symbol(syntax_module,"}");
  5950.   update_symbol(syntax_module,".");
  5951.   update_symbol(syntax_module,"?");
  5952.  
  5953.   
  5954.   cut            =update_symbol(syntax_module,"!");
  5955.   colonsym        =update_symbol(syntax_module,":");
  5956.   commasym        =update_symbol(syntax_module,",");
  5957.   disj_nil              =update_symbol(syntax_module,"{}");
  5958.   eof            =update_symbol(syntax_module,"end_of_file");
  5959.   eqsym            =update_symbol(syntax_module,"=");
  5960.   leftarrowsym        =update_symbol(syntax_module,"<-");
  5961.   funcsym        =update_symbol(syntax_module,"->");
  5962.   life_or               =update_symbol(syntax_module,";");/* RM: Apr 6 1993  */
  5963.   minus_symbol          =update_symbol(syntax_module,"-");/* RM: Jun 21 1993 */
  5964.   predsym        =update_symbol(syntax_module,":-");
  5965.   quote            =update_symbol(syntax_module,"`");
  5966.   such_that        =update_symbol(syntax_module,"|");
  5967.   top            =update_symbol(syntax_module,"@");
  5968.   typesym        =update_symbol(syntax_module,"::");
  5969.  
  5970.   /*  RM: Jul  7 1993  */
  5971.   final_dot        =update_symbol(syntax_module,"< . >");
  5972.   final_question    =update_symbol(syntax_module,"< ? >");
  5973.  
  5974.   
  5975.   
  5976.   /*  RM: Feb  3 1993  */
  5977.   set_current_module(bi_module);
  5978.   error_psi_term=heap_psi_term(4); /* 8.10 */
  5979.   error_psi_term->type=update_symbol(bi_module,"*** ERROR ***");
  5980.   error_psi_term->type->code=NOT_CODED;
  5981.  
  5982.   apply            =update_symbol(bi_module,"apply");
  5983.   boolean        =update_symbol(bi_module,"bool");
  5984.   boolpredsym        =update_symbol(bi_module,"bool_pred");
  5985.   built_in        =update_symbol(bi_module,"built_in");
  5986.   calloncesym           =update_symbol(bi_module,"call_once");
  5987.   /* colon sym */
  5988.   /* comma sym */
  5989.   comment        =update_symbol(bi_module,"comment");
  5990.  
  5991.   
  5992.   /*  RM: Dec 11 1992  conjunctions have been totally scrapped it seems */
  5993.   /* conjunction=update_symbol("*conjunction*"); 19.8 */
  5994.  
  5995.   constant        =update_symbol(bi_module,"*constant*");
  5996.   disjunction        =update_symbol(bi_module,"disj");/*RM:9 Dec 92*/
  5997.   false            =update_symbol(bi_module,"false");
  5998.   functor        =update_symbol(bi_module,"functor");
  5999.   iff            =update_symbol(bi_module,"cond");
  6000.   integer        =update_symbol(bi_module,"int");
  6001.   alist            =update_symbol(bi_module,"cons");/*RM:9 Dec 92*/
  6002.   nothing        =update_symbol(bi_module,"bottom");
  6003.   nil            =update_symbol(bi_module,"nil");/*RM:9 Dec 92*/
  6004.   quoted_string        =update_symbol(bi_module,"string");
  6005.   real            =update_symbol(bi_module,"real");
  6006.   stream        =update_symbol(bi_module,"stream");
  6007.   succeed        =update_symbol(bi_module,"succeed");
  6008.   true            =update_symbol(bi_module,"true");
  6009.   timesym        =update_symbol(bi_module,"time");
  6010.   variable        =update_symbol(bi_module,"*variable*");
  6011.   opsym            =update_symbol(bi_module,"op");
  6012.   loadsym        =update_symbol(bi_module,"load");
  6013.   dynamicsym        =update_symbol(bi_module,"dynamic");
  6014.   staticsym        =update_symbol(bi_module,"static");
  6015.   encodesym        =update_symbol(bi_module,"encode");
  6016.   listingsym        =update_symbol(bi_module,"c_listing");
  6017.   /* provesym        =update_symbol(bi_module,"prove"); */
  6018.   delay_checksym    =update_symbol(bi_module,"delay_check");
  6019.   eval_argsym        =update_symbol(bi_module,"non_strict");
  6020.   inputfilesym        =update_symbol(bi_module,"input_file");
  6021.   call_handlersym    =update_symbol(bi_module,"call_handler");
  6022.   xf_sym        =update_symbol(bi_module,"xf");
  6023.   yf_sym        =update_symbol(bi_module,"yf");
  6024.   fx_sym        =update_symbol(bi_module,"fx");
  6025.   fy_sym        =update_symbol(bi_module,"fy");
  6026.   xfx_sym        =update_symbol(bi_module,"xfx");
  6027.   xfy_sym        =update_symbol(bi_module,"xfy");
  6028.   yfx_sym        =update_symbol(bi_module,"yfx");
  6029.   nullsym        =update_symbol(bi_module,"<NULL PSI TERM>");
  6030.   null_psi_term        =heap_psi_term(4);
  6031.   null_psi_term->type    =nullsym;
  6032.  
  6033.  
  6034.   set_current_module(no_module); /*  RM: Feb  3 1993  */
  6035.   t=update_symbol(no_module,"1");
  6036.   one=t->keyword->symbol;
  6037.   t=update_symbol(no_module,"2");
  6038.   two=t->keyword->symbol;
  6039.   t=update_symbol(no_module,"3");
  6040.   three=t->keyword->symbol;
  6041.   set_current_module(bi_module); /*  RM: Feb  3 1993  */
  6042.   t=update_symbol(bi_module,"year");
  6043.   year_attr=t->keyword->symbol;
  6044.   t=update_symbol(bi_module,"month");
  6045.   month_attr=t->keyword->symbol;
  6046.   t=update_symbol(bi_module,"day");
  6047.   day_attr=t->keyword->symbol;
  6048.   t=update_symbol(bi_module,"hour");
  6049.   hour_attr=t->keyword->symbol;
  6050.   t=update_symbol(bi_module,"minute");
  6051.   minute_attr=t->keyword->symbol;
  6052.   t=update_symbol(bi_module,"second");
  6053.   second_attr=t->keyword->symbol;
  6054.   t=update_symbol(bi_module,"weekday");
  6055.   weekday_attr=t->keyword->symbol;
  6056.   
  6057.   nothing->type=type;
  6058.   top->type=type;
  6059.  
  6060.   /* Built-in routines */
  6061.  
  6062.   /* Program database */
  6063.   new_built_in(bi_module,"dynamic",predicate,c_dynamic);
  6064.   new_built_in(bi_module,"static",predicate,c_static);
  6065.   new_built_in(bi_module,"assert",predicate,c_assert_last);
  6066.   new_built_in(bi_module,"asserta",predicate,c_assert_first);
  6067.   new_built_in(bi_module,"clause",predicate,c_clause);
  6068.   new_built_in(bi_module,"retract",predicate,c_retract);
  6069.   new_built_in(bi_module,"setq",predicate,c_setq);
  6070.   new_built_in(bi_module,"c_listing",predicate,c_listing);
  6071.   new_built_in(bi_module,"print_codes",predicate,c_print_codes);
  6072.  
  6073.   /* File I/O */
  6074.   new_built_in(bi_module,"get",predicate,c_get);
  6075.   new_built_in(bi_module,"put",predicate,c_put);
  6076.   new_built_in(bi_module,"open_in",predicate,c_open_in);
  6077.   new_built_in(bi_module,"open_out",predicate,c_open_out);
  6078.   new_built_in(bi_module,"set_input",predicate,c_set_input);
  6079.   new_built_in(bi_module,"set_output",predicate,c_set_output);
  6080.   new_built_in(bi_module,"exists_file",predicate,c_exists);
  6081.   new_built_in(bi_module,"close",predicate,c_close);
  6082.   new_built_in(bi_module,"simple_load",predicate,c_load);
  6083.   new_built_in(bi_module,"put_err",predicate,c_put_err);
  6084.   new_built_in(bi_module,"chdir",predicate,c_chdir);
  6085.  
  6086.   /* Term I/O */
  6087.   new_built_in(bi_module,"write",predicate,c_write);
  6088.   new_built_in(bi_module,"writeq",predicate,c_writeq);
  6089.   new_built_in(bi_module,"pretty_write",predicate,c_pwrite);
  6090.   new_built_in(bi_module,"pretty_writeq",predicate,c_pwriteq);
  6091.   new_built_in(bi_module,"write_canonical",predicate,c_write_canonical);
  6092.   new_built_in(bi_module,"page_width",predicate,c_page_width);
  6093.   new_built_in(bi_module,"print_depth",predicate,c_print_depth);
  6094.   new_built_in(bi_module,"put_err",predicate,c_put_err);
  6095.   new_built_in(bi_module,"parse",function,c_parse);
  6096.   new_built_in(bi_module,"read",predicate,c_read_psi);
  6097.   new_built_in(bi_module,"read_token",predicate,c_read_token);
  6098.   new_built_in(bi_module,"c_op",predicate,c_op); /*  RM: Jan 13 1993  */
  6099.   new_built_in(bi_module,"ops",function,c_ops);
  6100.   new_built_in(bi_module,"write_err",predicate,c_write_err);
  6101.   new_built_in(bi_module,"writeq_err",predicate,c_writeq_err);
  6102.  
  6103.   /* Type checks */
  6104.   new_built_in(bi_module,"nonvar",function,c_nonvar);
  6105.   new_built_in(bi_module,"var",function,c_var);
  6106.   new_built_in(bi_module,"is_function",function,c_is_function);
  6107.   new_built_in(bi_module,"is_predicate",function,c_is_predicate);
  6108.   new_built_in(bi_module,"is_sort",function,c_is_sort);
  6109.   
  6110.   new_built_in(bi_module,
  6111.            disjunction->keyword->symbol,
  6112.            function,
  6113.            c_eval_disjunction);
  6114.   
  6115.   /*  RM: Dec 16 1992  So the symbol can be changed easily */
  6116.  
  6117.   
  6118.   /* Arithmetic */
  6119.   insert_math_builtins();
  6120.  
  6121.   /* Comparison */
  6122.   new_built_in(syntax_module,"<",function,c_lt);  
  6123.   new_built_in(syntax_module,"=<",function,c_ltoe);  
  6124.   new_built_in(syntax_module,">",function,c_gt);  
  6125.   new_built_in(syntax_module,">=",function,c_gtoe);  
  6126.   new_built_in(syntax_module,"=\\=",function,c_diff);
  6127.   new_built_in(syntax_module,"=:=",function,c_equal);
  6128.   new_built_in(syntax_module,"and",function,c_and);
  6129.   new_built_in(syntax_module,"or",function,c_or);
  6130.   new_built_in(syntax_module,"not",function,c_not);
  6131.   new_built_in(syntax_module,"xor",function,c_xor);
  6132.   new_built_in(syntax_module,"===",function,c_same_address);
  6133.   
  6134.   /* RM: Nov 22 1993  */
  6135.   new_built_in(syntax_module,"\\===",function,c_diff_address); 
  6136.  
  6137.   /* Psi-term navigation */
  6138.   new_built_in(bi_module,"features",function,c_features);
  6139.   new_built_in(bi_module,"feature_values",function,c_feature_values); /* RM: Mar  3 1994  */
  6140.  
  6141.   /*  RM: Jul 20 1993  */
  6142.   
  6143.   new_built_in(syntax_module,".",function,c_project);/*  RM: Jul  7 1993  */
  6144.   new_built_in(bi_module,"root_sort",function,c_rootsort);
  6145.   new_built_in(bi_module,"strip",function,c_strip);
  6146.   new_built_in(bi_module,"copy_pointer",function,c_copy_pointer); /* PVR: Dec 17 1992 */
  6147.   new_built_in(bi_module,"has_feature",function,c_exist_feature); /* PVR: Dec 17 1992 */
  6148.  
  6149.   /* Unification and assignment */
  6150.   new_built_in(syntax_module,"<-",predicate,c_bk_assign);
  6151.   /* new_built_in(syntax_module,"<<-",predicate,c_assign);  RM: Feb 24 1993  */
  6152.   
  6153.   /*  RM: Feb 24 1993  */
  6154.   new_built_in(syntax_module,"<<-",predicate,c_global_assign);
  6155.   /* new_built_in(syntax_module,"<<<-",predicate,c_global_assign); */
  6156.   
  6157.   /*  RM: Feb  8 1993  */
  6158.   new_built_in(syntax_module,"{}",function,c_fail); /*  RM: Feb 16 1993  */
  6159.   new_built_in(syntax_module,"=",predicate,c_unify_pred);
  6160.   new_built_in(syntax_module,"&",function,c_unify_func);
  6161.   new_built_in(bi_module,"copy_term",function,c_copy_term);
  6162.   /* UNI new_built_in(syntax_module,":",function,c_unify_func); */
  6163.  
  6164.   /* Type hierarchy navigation */
  6165.   insert_type_builtins();
  6166.  
  6167.   /* String and character utilities */
  6168.   new_built_in(bi_module,"str2psi",function,c_string2psi);
  6169.   new_built_in(bi_module,"psi2str",function,c_psi2string);
  6170.   new_built_in(bi_module,"int2str",function,c_int2string);
  6171.   new_built_in(bi_module,"asc",function,c_ascii);
  6172.   new_built_in(bi_module,"chr",function,c_char);
  6173.  
  6174.   /* Control */
  6175.   new_built_in(syntax_module,"|",function,c_such_that);
  6176.   new_built_in(bi_module,"cond",function,c_cond);
  6177.   new_built_in(bi_module,"if",function,c_cond);
  6178.   new_built_in(bi_module,"eval",function,c_eval);
  6179.   new_built_in(bi_module,"evalin",function,c_eval_inplace);
  6180.   /* new_built_in(bi_module,"quote",function,c_quote); */
  6181.   /*new_built_in(bi_module,"call_once",function,c_call_once);*/ /* DENYS: Jan 25 1995 */
  6182.   /* new_built_in(bi_module,"call",function,c_call); */
  6183.   /* new_built_in(bi_module,"undefined",function,c_fail); */ /* RM: Jan 13 1993 */
  6184.   new_built_in(bi_module,"print_variables",predicate,c_print_variables);
  6185.   new_built_in(bi_module,"get_choice",function,c_get_choice);
  6186.   new_built_in(bi_module,"set_choice",predicate,c_set_choice);
  6187.   new_built_in(bi_module,"exists_choice",function,c_exists_choice);
  6188.   new_built_in(bi_module,"apply",function,c_apply);
  6189.   new_built_in(bi_module,"bool_pred",predicate,c_boolpred);
  6190.  
  6191.   new_built_in(syntax_module,":-",predicate,c_declaration);
  6192.   new_built_in(syntax_module,"->",predicate,c_declaration);
  6193.   /* new_built_in(syntax_module,"::",predicate,c_declaration); */
  6194.   new_built_in(syntax_module,"<|",predicate,c_declaration);
  6195.   new_built_in(syntax_module,":=",predicate,c_declaration);
  6196.   new_built_in(syntax_module,";",predicate,c_disj);
  6197.   new_built_in(syntax_module,"!",predicate,c_not_implemented);
  6198.   new_built_in(syntax_module,",",predicate,c_succeed);
  6199.   new_built_in(bi_module,"abort",predicate,c_abort);
  6200.   new_built_in(bi_module,"halt",predicate,c_halt);
  6201.   new_built_in(bi_module,"succeed",predicate,c_succeed);
  6202.   new_built_in(bi_module,"repeat",predicate,c_repeat);
  6203.   new_built_in(bi_module,"fail",predicate,c_fail);
  6204.   /* new_built_in(bi_module,"freeze",predicate,c_freeze); PVR 16.9.93 */
  6205.   new_built_in(bi_module,"implies",predicate,c_implies);
  6206.   new_built_in(bi_module,"undo",predicate,c_undo);
  6207.   new_built_in(bi_module,"delay_check",predicate,c_delay_check);
  6208.   new_built_in(bi_module,"non_strict",predicate,c_non_strict);
  6209.   
  6210.   /* System */
  6211.   insert_system_builtins();
  6212.  
  6213.   new_built_in(bi_module,"strcon",function,c_concatenate);
  6214.   new_built_in(bi_module,"strlen",function,c_string_length);
  6215.   new_built_in(bi_module,"substr",function,c_sub_string);
  6216.   new_built_in(bi_module,"append_file",predicate,c_append_file);
  6217.   new_built_in(bi_module,"random",function,c_random);
  6218.   new_built_in(bi_module,"initrandom",predicate,c_initrandom);
  6219.  
  6220.   /*  RM: Jan  8 1993  */
  6221.   new_built_in(bi_module,"set_module",predicate,c_set_module);
  6222.   new_built_in(bi_module,"open_module",predicate,c_open_module);
  6223.   new_built_in(bi_module,"public",predicate,c_public);
  6224.   new_built_in(bi_module,"private",predicate,c_private);
  6225.   new_built_in(bi_module,"display_modules",predicate,c_display_modules);
  6226.   new_built_in(bi_module,"trace_input",predicate,c_trace_input);
  6227.   new_built_in(bi_module,"substitute",predicate,c_replace);
  6228.   new_built_in(bi_module,"current_module",function,c_current_module);
  6229.   new_built_in(bi_module,"module_name",function,c_module_name);
  6230.   new_built_in(bi_module,"combined_name",function,c_combined_name);
  6231.   /* new_built_in(bi_module,"#",function,c_module_access); */
  6232.   
  6233.   /* Hack so '.set_up' doesn't issue a Warning message */
  6234.   /*  RM: Feb  3 1993  */
  6235.   hash_lookup(bi_module->symbol_table,"set_module")->public=TRUE;
  6236.   hash_lookup(bi_module->symbol_table,"built_in")->public=TRUE;
  6237.  
  6238.   /*  RM: Jan 29 1993  */
  6239.   abortsym=update_symbol(bi_module,"abort"); /* 26.1 */
  6240.   aborthooksym=update_symbol(bi_module,"aborthook"); /* 26.1 */
  6241.   tracesym=update_symbol(bi_module,"trace"); /* 26.1 */
  6242.  
  6243.   
  6244.   /*  RM: Feb  9 1993  */
  6245.   new_built_in(bi_module,"global",predicate,c_global);
  6246.   new_built_in(bi_module,"persistent",predicate,c_persistent);
  6247.   new_built_in(bi_module,"display_persistent",predicate,c_display_persistent);
  6248.   new_built_in(bi_module,"alias",predicate,c_alias);
  6249.  
  6250.   /*  RM: Mar 11 1993  */
  6251.   new_built_in(bi_module,"private_feature",predicate,c_private_feature);
  6252.   add_module1=update_symbol(bi_module,"features");
  6253.   add_module2=update_symbol(bi_module,"str2psi");
  6254.   add_module3=update_symbol(bi_module,"feature_values"); /* RM: Mar  3 1994  */
  6255.  
  6256.   /*  RM: Jun 29 1993  */
  6257.   new_built_in(bi_module,"split_double",function,c_split_double);
  6258.   new_built_in(bi_module,"string_address",function,c_string_address);
  6259.  
  6260.   /*  RM: Jul 15 1993  */
  6261.   new_built_in(bi_module,"deref_length",function,c_deref_length);
  6262.  
  6263.  
  6264.   /*  RM: Sep 20 1993  */
  6265.   new_built_in(bi_module,"argv",function,c_args);
  6266.  
  6267.   /* RM: Jan 28 1994  */
  6268.   new_built_in(bi_module,"public_symbols",function,all_public_symbols);
  6269.            
  6270. #ifdef CLIFE
  6271.   life_reals();
  6272. #endif /* CLIFE */
  6273.  
  6274.   insert_sys_builtins();
  6275. }
  6276.