home *** CD-ROM | disk | FTP | other *** search
/ The C Users' Group Library 1994 August / wc-cdrom-cusersgrouplibrary-1994-08.iso / vol_200 / 297_01 / prbltin.c < prev    next >
C/C++ Source or Header  |  1992-01-01  |  57KB  |  1,842 lines
  1. /* prbltin.c */
  2. /* The builtin predicates are defined here.
  3.  * If you want lots of builtins then make several files that
  4.  * include prbltin.h.
  5.  */
  6.  
  7. /* Dec 18 88 HdeF Simplified remove clause so that it expects just one
  8.  *      argument.
  9.  * 12/25/91 HdeF, added repeat,gennum predicates
  10.  * 01/01/92 HdeF, added reverse_trace_mode, no_reverse_trace_mode
  11.  */
  12. #include <stdio.h>
  13. #include <ctype.h>
  14. #include <assert.h>
  15. #include "prtypes.h"
  16. #include "prbltin.h"
  17. #include "prlush.h"
  18.  
  19. #define ATOMORSTRING     "atom or string"
  20. #define CANTOPEN     "can't open %s"
  21. #define TOOMANYFILES     "Too many open files"
  22.  
  23. extern subst_ptr_t Subst_mem; /* bottom of (global) variable bindings stack */
  24. extern subst_ptr_t my_Subst_alloc();
  25.  
  26. extern string_ptr_t get_string();
  27. extern atom_ptr_t   Nil;
  28. extern FILE *        Curr_infile;
  29. extern FILE *        Curr_outfile;
  30. extern node_ptr_t   ND_builtin_next_nodeptr;/* from prlush.c */
  31. static int Nbuiltins; /* not used but you could used this to keep track of
  32.                         the builtins you add */
  33. int Trace_flag; /* used by Ptrace(), Pnotrace(), lush() */
  34. int Tracing_now;
  35.  
  36. /* This is used to test if an atom is a builtin. 
  37.  * We rely on the fact that any atom less than LastBuiltin is created by
  38.  * a call to make_builtin()
  39.  */
  40. atom_ptr_t LastBuiltin;
  41.  
  42. /****************************************************************************
  43.                 make_builtin()
  44.  This associates a name used at the interpreter level with a builtin.
  45.  ****************************************************************************/
  46. void make_builtin(fun, prolog_name)
  47. intfun fun;
  48. char *prolog_name;
  49. {
  50.         atom_ptr_t atomptr, intern();
  51.  
  52.         atomptr = intern(prolog_name);
  53.         ATOMPTR_BUILTIN(atomptr) = fun;
  54.         LastBuiltin = atomptr;
  55.         record_pred(atomptr);
  56.         Nbuiltins++;
  57. }
  58.  
  59. /*****************************************************************************
  60.                         nth_arg()
  61.  Returns NULL if error .
  62.  Otherwise returns the nth argument of current goal's arguments.
  63.  The return value is equal to DerefNode
  64.  Obviously one could be more efficient than here.
  65.  *****************************************************************************/
  66. node_ptr_t nth_arg(narg)
  67. {
  68.  
  69.         node_ptr_t rest_args;
  70.  
  71.         dereference(Arguments, SubstGoal);
  72.         if(NODEPTR_TYPE(DerefNode) != PAIR)
  73.         {
  74.                 return(NULL);
  75.         }
  76.         rest_args = DerefNode;
  77.         --narg;
  78.         while(narg)
  79.         {
  80.                 --narg;
  81.                 dereference(NODEPTR_TAIL(rest_args), DerefSubst);
  82.                 if(NODEPTR_TYPE(DerefNode) != PAIR)
  83.                 {
  84.                         return(NULL);
  85.                 }
  86.                 rest_args = DerefNode;
  87.         }
  88.         dereference(NODEPTR_HEAD(rest_args), DerefSubst);
  89.         return(DerefNode);
  90. }
  91.  
  92. /**********************************************************************
  93.                         type_first_arg()
  94. Returns true if the type of the first arg to the call is equal
  95.  to the argument of the function.
  96.  **********************************************************************/
  97. type_first_arg(type)
  98. objtype_t type;
  99. {
  100. dereference(Arguments, SubstGoal);
  101. if(NODEPTR_TYPE(DerefNode) != PAIR)
  102.   return(nargerr(1)); 
  103.   else 
  104.     dereference(NODEPTR_HEAD(DerefNode), DerefSubst);
  105.     return(NODEPTR_TYPE(DerefNode) == type);
  106. }
  107.  
  108. /*-------------------------------------------------------------------*/
  109. /* unify the nth argument of goal with an int of value val */
  110. bind_int(narg, val)
  111. integer val;
  112. {
  113.         extern subst_ptr_t Subst_mem;
  114.         node_ptr_t nodeptr, get_node();
  115.  
  116.         if(!nth_arg(narg))return(nargerr(narg));
  117.  
  118.         nodeptr = get_node(DYNAMIC);
  119.         NODEPTR_TYPE(nodeptr) = INT;
  120.         NODEPTR_INT(nodeptr) = val;
  121.  
  122.         return(unify(DerefNode, DerefSubst, nodeptr, Subst_mem));
  123. }
  124.  
  125. #ifdef CHARACTER
  126. /*-------------------------------------------------------------------*/
  127. /* unify the nth argument of goal with a char of value val */
  128. bind_character(narg, val)
  129. uchar_t val;
  130. {
  131.         extern subst_ptr_t Subst_mem;
  132.         node_ptr_t nodeptr, get_node();
  133.  
  134.         if(!nth_arg(narg))return(nargerr(narg));
  135.  
  136.         nodeptr = get_node(DYNAMIC);
  137.         NODEPTR_TYPE(nodeptr) = CHARACTER;
  138.         NODEPTR_CHARACTER(nodeptr) = val;
  139.  
  140.         return(unify(DerefNode, DerefSubst, nodeptr, Subst_mem));
  141. }
  142. #endif
  143.  
  144. #ifdef REAL
  145. /*-------------------------------------------------------------------*/
  146. /* unify the nth argument of goal with a real of value val */
  147. bind_real(narg, val)
  148. real val;
  149. {
  150.         node_ptr_t nodeptr, get_node();
  151.         real_ptr_t realptr, get_real();
  152.  
  153.         if(!nth_arg(narg))return(nargerr(narg));
  154.  
  155.         nodeptr = get_node(DYNAMIC);
  156.         NODEPTR_TYPE(nodeptr) = REAL;
  157.         realptr = get_real(DYNAMIC);
  158.         *realptr = val;
  159.         NODEPTR_REALP(nodeptr) = realptr;
  160.  
  161.         return(unify(DerefNode, DerefSubst, nodeptr, Subst_mem));
  162. }
  163. #endif
  164.  
  165. /*-------------------------------------------------------------------*/
  166. /* unify the nth argument of goal with an int of value val */
  167. bind_clause(narg, val)
  168. clause_ptr_t val;
  169. {
  170.         node_ptr_t nodeptr, get_node();
  171.         extern subst_ptr_t Subst_mem;
  172.  
  173.         if(!nth_arg(narg))return(nargerr(narg));
  174.  
  175.         nodeptr = get_node(DYNAMIC);
  176.         NODEPTR_TYPE(nodeptr) = CLAUSE;
  177.         NODEPTR_CLAUSE(nodeptr) = val;
  178.  
  179.         return(unify(DerefNode, DerefSubst, nodeptr, Subst_mem));
  180. }
  181.  
  182.  
  183. /*-------------------------------------------------------------------*/
  184. /* unify the nth argument of goal with an atom*/
  185. bind_atom(narg, atomptr)
  186. atom_ptr_t atomptr;
  187. {
  188.         extern subst_ptr_t Subst_mem;
  189.         node_ptr_t nodeptr, get_node();
  190.  
  191.         if(!nth_arg(narg))return(nargerr(narg));
  192.  
  193.         nodeptr = get_node(DYNAMIC);
  194.         NODEPTR_TYPE(nodeptr) = ATOM;
  195.         NODEPTR_ATOM(nodeptr) = atomptr;
  196.  
  197.         return(unify(DerefNode, DerefSubst, nodeptr, Subst_mem));
  198. }
  199. /*-------------------------------------------------------------------*/
  200. /* unify the nth argument of goal with a copy of the string*/
  201. bind_string(narg, stringptr)
  202. string_ptr_t stringptr;
  203. {
  204.         extern subst_ptr_t Subst_mem;
  205.         node_ptr_t nodeptr, get_node();
  206.         string_ptr_t s;
  207.  
  208.         if(!nth_arg(narg))return(nargerr(narg));
  209.  
  210.         nodeptr = get_node(DYNAMIC);
  211.         NODEPTR_TYPE(nodeptr) = STRING;
  212.         s = get_string((my_alloc_size_t)strlen(stringptr)+1 , DYNAMIC);
  213.         strcpy(s, stringptr);
  214.         NODEPTR_STRING(nodeptr) = s;
  215.  
  216.  
  217.         return(unify(DerefNode, DerefSubst, nodeptr, Subst_mem));
  218. }
  219.  
  220. /*----------------------------------------------------------------------------
  221.   The functions corresponding to the builtins are as follows.
  222.   The correct syntax for the call refers to the syntax in 
  223.   prmanual.txt.
  224.   ----------------------------------------------------------------------------*/
  225.  
  226.  
  227. /******************************************************************************
  228.                         (tell <output_file:string>)
  229. Send output to file. Open file if not already open.
  230. As in Edinburgh Prolog.
  231. See Clocksin and Mellish, or Bratko for more details, or read the code!
  232.  ******************************************************************************/
  233. /* this stores the open output files */
  234. struct named_ofile Open_ofiles[MAXOPEN];/* the value of MAXOPEN depends on the OS */
  235.  
  236. /* this stores the open input files */
  237. struct named_ifile Open_ifiles[MAXOPEN];/* the value of MAXOPEN depends on the OS */
  238.  
  239. void ini_named_files()
  240. {
  241. int i;
  242.  
  243.      Open_ofiles[0].o_filename = "user";
  244.      Open_ofiles[0].o_fp = stdout;
  245.  
  246. for(i = 1 ; i < MAXOPEN; i++)
  247.    {
  248.      Open_ofiles[i].o_filename = "";
  249.      Open_ofiles[i].o_fp = NULL;
  250.    }
  251.  
  252.      Open_ifiles[0].i_filename = "user";
  253.      Open_ifiles[0].i_fp = stdin;
  254.  
  255. for(i = 1 ; i < MAXOPEN; i++)
  256.    {
  257.      Open_ifiles[i].i_filename = "";
  258.      Open_ifiles[i].i_fp = NULL;
  259.    }
  260.  
  261. }
  262.  
  263. open_output(filename)
  264. char *filename;
  265. {
  266. int i, unused;
  267. FILE *ofp;
  268.  
  269. for(i = 0, unused = MAXOPEN; i < MAXOPEN; i++)
  270.    {
  271.    if(*(Open_ofiles[i].o_filename) == '\0')
  272.      unused = i;
  273.  
  274.    if(!strcmp(filename, Open_ofiles[i].o_filename)){
  275.         Curr_outfile = Open_ofiles[i].o_fp;
  276.         return 1;
  277.         }
  278.    }
  279.  
  280. if(unused < MAXOPEN)
  281.   {
  282.         if((ofp = fopen(filename, "w")) == NULL)
  283.         {
  284.                 sprintf(Print_buffer, CANTOPEN, filename);
  285.                 errmsg(Print_buffer);
  286.                 return 0;
  287.         }
  288.         else
  289.         {
  290.                 Curr_outfile = ofp;
  291.                 Open_ofiles[unused].o_fp = ofp;
  292.                 Open_ofiles[unused].o_filename = 
  293.             get_string((my_alloc_size_t)strlen(filename) + 1, 
  294.                     PERM_STRING);
  295.                 strcpy(Open_ofiles[unused].o_filename, filename);
  296.                 return 1;
  297.         }
  298.   }
  299. else
  300.   {
  301.   errmsg(TOOMANYFILES);
  302.   return 0;
  303.   }
  304. }
  305.  
  306.  
  307. Ptell()
  308. {
  309.         char *filename;
  310.  
  311.         ARG_STRING(1, filename);
  312.         return (open_output(filename));
  313. }
  314.  
  315. /******************************************************************************
  316.                         (telling <output_file:string>)
  317.                         (telling <output_file:variable>)
  318. As in Edinburgh Prolog.
  319.  Unifies the argument with the name of the current output_file
  320.  ******************************************************************************/
  321. char *get_output_name()
  322. {
  323. int i;
  324.  
  325. for(i = 0; i < MAXOPEN; i++)
  326.         {
  327.         if(Curr_outfile == Open_ofiles[i].o_fp)
  328.                 return(Open_ofiles[i].o_filename);
  329.  
  330.         }
  331.  
  332. INTERNAL_ERROR("telling");
  333. return(NULL);
  334. }
  335.  
  336. Ptelling()
  337. {
  338. return(bind_string(1, get_output_name()));
  339. }
  340.  
  341. /******************************************************************************
  342.                 (told)
  343. As in Edinburgh Prolog.
  344.  Closes current outfile.
  345.  ******************************************************************************/
  346. close_output(ofp)
  347. FILE *ofp;
  348. {
  349. int i;
  350.  
  351. if (ofp == stdout)
  352.    return 1;
  353.  
  354. for(i = 1; i < MAXOPEN; i++)
  355.    {
  356.    if(Curr_outfile == Open_ofiles[i].o_fp){
  357.         fclose(Open_ofiles[i].o_fp);
  358.         Open_ofiles[i].o_fp = NULL;
  359.         Open_ofiles[i].o_filename = "";
  360.         Curr_outfile = stdout;
  361.         return 1;
  362.         }
  363.    }
  364. INTERNAL_ERROR("close_output");
  365. return(0);/* for lint */
  366. }
  367.  
  368. Ptold()
  369. {
  370.         return(close_output(Curr_outfile));
  371. }
  372.  
  373. /**********************************************************************
  374.                 (display <anything_to_display:argument>)
  375.                 (display <anything_to_display:argument> <var:output length>)
  376. ***********************************************************************/
  377. Pdisplay()      /* display term                 */
  378. {
  379.     int len;
  380.     if(!nth_arg(1))return(nargerr(1));
  381.         len = out_node(DerefNode, DerefSubst);
  382.     if(nth_arg(2)) /* o.k. this could be more efficient */
  383.       return(bind_int(2, (integer)len));
  384.     else
  385.         return(TRUE);
  386. }
  387.  
  388. /**********************************************************************
  389.                 (writes <output_string:string>)
  390. ***********************************************************************/
  391. Pwrites()       /* write string without quotes */
  392. {
  393.         char *s;
  394.  
  395.         ARG_STRING(1, s);
  396.         pr_string(s);
  397.         return(TRUE);
  398. }
  399.  
  400. /**********************************************************************
  401.                         (put <ascii_code:integer>)
  402.  As in Edinburgh Prolog.
  403.  **********************************************************************/
  404. Pput()
  405. {
  406.         integer c;
  407.  
  408.         ARG_INT(1, c);
  409.         *Print_buffer = (char)c;
  410.         Print_buffer[1] = '\0';
  411.         pr_string(Print_buffer);
  412.         return(1);
  413. }
  414.  
  415. /**********************************************************************
  416.                         (nl)
  417. As in Edinburgh Prolog.
  418. ***********************************************************************/
  419. Pnl()           /* write newline                */
  420. {
  421.         pr_string("\n");
  422.         return(TRUE);
  423. }
  424.  
  425. /**********************************************************************
  426.                         (fail)
  427. As in Edinburgh Prolog.
  428. ***********************************************************************/
  429. Pfail()         /* use this to fail             */
  430. {
  431.         return(FAIL);
  432. }
  433.  
  434. /**********************************************************************
  435.                                 (quit)
  436. ***********************************************************************/
  437. Pquit()         /* leave prolog                 */
  438. {
  439.         return(QUIT);
  440. }
  441.  
  442. /**********************************************************************
  443.                                 (abort)
  444. ***********************************************************************/
  445. Pabort()                /* leave prolog                 */
  446. {
  447.         return(ABORT);
  448. }
  449.  
  450. /**********************************************************************
  451.             (repeat)
  452.  This predicate succeeds and backtracks indefinitely. It is better to
  453.  define it as a builtin rather than as rules because it wont overflow
  454.  the stack this way.
  455.  *********************************************************************/
  456. Prepeat()
  457. {
  458.     return (ND_SUCCESS);
  459. }
  460.  
  461. /******************************************************************************
  462.         (gennum <variable> <limit:positive integer>)
  463.  Backtrack through the numbers from 0 to limit
  464.  ******************************************************************************/
  465.  
  466. Pgennum()
  467. {
  468.    extern subst_ptr_t OldSubstTop , Subst_ptr;
  469.    extern node_ptr_t **OldTrailTop,**Trail_ptr;
  470.    integer limit;
  471.    node_ptr_t nodeptr,get_node();
  472.  
  473.    ARG_INT(2, limit);
  474.  
  475.    if(limit < 0)
  476.       return 0;
  477.  
  478.         OldSubstTop = Subst_ptr;
  479.         OldTrailTop = Trail_ptr;
  480.  
  481.    if(ND_builtin_next_nodeptr == NULL)/* first call */
  482.    {
  483.        nodeptr = get_node(DYNAMIC);
  484.        NODEPTR_TYPE(nodeptr)= INT; 
  485.        NODEPTR_INT(nodeptr)= 0; /* initial value */
  486.        ND_builtin_next_nodeptr = nodeptr; 
  487.    }
  488.    else
  489.    {
  490.        assert(NODEPTR_TYPE(ND_builtin_next_nodeptr)== INT); 
  491.    }
  492.  
  493.    if(NODEPTR_INT(ND_builtin_next_nodeptr)== limit)
  494.    {
  495.        return (bind_int(1, limit)); /* last possible success */
  496.    }
  497.    else
  498.    {
  499.        nodeptr = nth_arg(1); 
  500.  
  501.        if(NODEPTR_TYPE(nodeptr)== VAR)
  502.        {
  503.            bind_int(1, NODEPTR_INT(ND_builtin_next_nodeptr)++); /* update value for next time */
  504.            return  ND_SUCCESS; 
  505.        }
  506.        else
  507.        {
  508.            return (NODEPTR_INT(DerefNode)<= limit); /* in case the first arg is bound */
  509.        }
  510.  
  511.    }
  512.  
  513. }
  514.  
  515.  
  516. /**********************************************************************
  517.                         (cut)
  518. As in Edinburgh Prolog.
  519. To be honest implementations of cut are never quite the same
  520. because the behaviour of (not(not (cut))) will vary !
  521. ***********************************************************************/
  522. Pcut()          /* infamous cut control pred    */
  523. {
  524.         do_cut();/* see prlush.c */
  525.         return(TRUE);
  526. }
  527.  
  528. /**********************************************************************
  529.                         (integer <thing_tested:argument>)
  530. As in Edinburgh Prolog.
  531. ***********************************************************************/
  532. Pinteger()      /* test if argument is integer  */
  533. {
  534.         return(type_first_arg(INT));
  535. }
  536. /**********************************************************************
  537.                         (atom <thing_tested:argument>)
  538. As in Edinburgh Prolog.
  539. ***********************************************************************/
  540. Patom() /* test if argument is atom     */
  541. {
  542.         return(type_first_arg(ATOM));
  543. }
  544.  
  545. #ifdef REAL
  546. /**********************************************************************
  547.                         (real <thing_tested:argument>)
  548. ***********************************************************************/
  549. Preal() /* test if argument is real*/
  550. {
  551.         return(type_first_arg(REAL));
  552. }
  553. #endif
  554.  
  555. /**********************************************************************
  556.                         (string <thing_tested:argument>)
  557. ***********************************************************************/
  558. Pstring()       /* test if argument is string   */
  559. {
  560.         return(type_first_arg(STRING));
  561. }
  562.  
  563. /**********************************************************************
  564.                         (var <thing_tested:argument>)
  565. As in Edinburgh Prolog.
  566. ***********************************************************************/
  567. Pvar()          /* test if argument is variable */
  568. {
  569.         return(type_first_arg(VAR));
  570. }
  571. /**********************************************************************
  572.                         (nonvar <thing_tested:argument>)
  573. As in Edinburgh Prolog.
  574. ***********************************************************************/
  575. Pnonvar()               /* test if argument is not variable */
  576. {
  577.         switch(type_first_arg(VAR))
  578.         {
  579.         case 0:
  580.         return 1;
  581.         case 1:
  582.         return 0;
  583.         default:
  584.         return CRASH;
  585.         }
  586. }
  587. /**********************************************************************
  588.                         (atomic <thing_tested:argument>)
  589. As in Edinburgh Prolog.
  590. ***********************************************************************/
  591. Patomic()               /* test if argument is atomic */
  592. {
  593.     if(!nth_arg(1))return(nargerr(1));
  594.  
  595.         switch(NODEPTR_TYPE(DerefNode))
  596.         {
  597.         case ATOM:
  598.         case INT:
  599. #ifdef REAL
  600.         case REAL:
  601. #endif
  602. #ifdef CHARACTER
  603.     case CHARACTER:
  604. #endif
  605.         case STRING:
  606.                 return(1);
  607.         default:
  608.                 return(0);
  609.         }
  610. }
  611.  
  612. /**********************************************************************
  613.                         (iplus <arg1:integer><arg2:integer><sum:argument>)
  614. ***********************************************************************/
  615. Piplus() /* third arg is sum of first two (integers only) */
  616. {
  617.         integer i1, i2;
  618.  
  619.         ARG_INT(1, i1);
  620.         ARG_INT(2, i2);
  621.  
  622.         return(bind_int(3, i1 + i2));
  623. }
  624.  
  625. /**********************************************************************
  626.                         (iminus <arg1:integer><arg2:integer><difference:argument>)
  627. ***********************************************************************/
  628. Piminus() /* third arg is difference of first two (integers only) */
  629. {
  630.         integer i1, i2;
  631.  
  632.         ARG_INT(1, i1);
  633.         ARG_INT(2, i2);
  634.  
  635.         return(bind_int(3, i1 - i2));
  636. }
  637.  
  638. /**********************************************************************
  639.                         (imult <arg1:integer><arg2:integer><argument>)
  640. ***********************************************************************/
  641. Pimult() /* third arg is product of first two (integers only) */
  642. {
  643.         integer i1, i2;
  644.  
  645.         ARG_INT(1, i1);
  646.         ARG_INT(2, i2);
  647.  
  648.         return(bind_int(3, i1 * i2));
  649. }
  650.  
  651. #ifdef REAL
  652. /**********************************************************************
  653.                         (rplus <arg1:integer><arg2:integer><argument>)
  654. ***********************************************************************/
  655. Prplus() /* third arg is sum of first two (reals only) */
  656. {
  657.         real r1, r2;
  658.  
  659.         ARG_REAL(1, r1);
  660.         ARG_REAL(2, r2);
  661.  
  662.         return(bind_real(3, r1 + r2));
  663. }
  664. #endif
  665.  
  666. /**********************************************************************
  667.                         (iless <arg1:integer><arg2:integer>)
  668. ***********************************************************************/
  669. /* compares integers - you should generalise this to make it more useful */
  670. Piless()
  671. {
  672.         integer i1, i2;
  673.  
  674.         ARG_INT(1, i1);
  675.         ARG_INT(2, i2);
  676.  
  677.         return(i1 < i2);
  678. }
  679. /**********************************************************************
  680.                         (rless <arg1:real><arg2:real>)
  681. ***********************************************************************/
  682. /* compares reals - you should generalise this to make it more useful */
  683. Prless()
  684. {
  685.         real i1, i2;
  686.  
  687.         ARG_REAL(1, i1);
  688.         ARG_REAL(2, i2);
  689.  
  690.         return(i1 < i2);
  691. }
  692.  
  693. /**********************************************************************
  694.                         (ileq <arg1:integer><arg2:integer>)
  695. ***********************************************************************/
  696. /* compares integers - you should generalise this to make it more useful */
  697. Pileq()
  698. {
  699.         integer i1, i2;
  700.  
  701.         ARG_INT(1, i1);
  702.         ARG_INT(2, i2);
  703.  
  704.         return((i1 <= i2));
  705. }
  706.  
  707. /**********************************************************************
  708.                 imodify(<arg1:integer><arg2:integer>)
  709. Most unlike Prolog!
  710. ***********************************************************************/
  711. /* Lets you copy the integer value of the second argument into the first.
  712.  *  You must use this with extreme restraint. It is better than 
  713.  * frequently seen code of the kind 
  714.  * increment_counter:-counter(N), retract(counter(N)), M is N+1, asserta(counter(M)).
  715.  * which is not efficient.
  716.  */
  717.  
  718. Pimodify()
  719. {
  720.         integer i2;
  721.  
  722.         ARG_INT(2, i2);
  723.         CHECK_TYPE_ARG(1, INT);/* verify only */
  724.  
  725.         NODEPTR_INT(DerefNode) = i2;
  726.         return(TRUE);
  727. }
  728.  
  729. /**********************************************************************
  730.                         (see <input_file:string>)
  731.  Make <string> the current infile.
  732. As in Edinburgh Prolog except that the argument is a string or variable.
  733.  **********************************************************************/
  734. open_input(filename)
  735. char *filename;
  736. {
  737. int i, unused;
  738. FILE *ifp;
  739.  
  740. for(i = 0, unused = MAXOPEN; i < MAXOPEN; i++)
  741.    {
  742.    if(*(Open_ifiles[i].i_filename) == '\0')
  743.      unused = i;
  744.  
  745.    if(!strcmp(filename, Open_ifiles[i].i_filename)){
  746.         Curr_infile = Open_ifiles[i].i_fp;
  747.         return 1;
  748.         }
  749.    }
  750.  
  751. if(unused < MAXOPEN)
  752.   {
  753.         if((ifp = fopen(filename, "r")) == NULL)
  754.         {
  755.                 sprintf(Print_buffer, CANTOPEN, filename);
  756.                 errmsg(Print_buffer);
  757.                 return 0;
  758.         }
  759.         else
  760.         {
  761.                 Curr_infile = ifp;
  762.                 Open_ifiles[unused].i_fp = ifp;
  763.                 Open_ifiles[unused].i_filename = 
  764.             get_string((my_alloc_size_t)strlen(filename) + 1,
  765.                      PERM_STRING);
  766.                 strcpy(Open_ifiles[unused].i_filename, filename);
  767.                 return 1;
  768.         }
  769.   }
  770. else
  771.   {
  772.   errmsg(TOOMANYFILES);
  773.   return 0;
  774.   }
  775. }
  776.  
  777. Psee()
  778. {
  779.         char *filename;
  780.         ARG_STRING(1, filename);
  781.  
  782.         return(open_input(filename));
  783. }
  784. /******************************************************************************
  785.                         (seeing <output_file:string>)
  786.                         (seeing <output_file:variable>)
  787. As in Edinburgh Prolog.
  788.  Unifies the argument with the name of the current input_file
  789.  ******************************************************************************/
  790. char *get_input_name()
  791. {
  792. int i;
  793.  
  794. for(i = 0; i < MAXOPEN; i++)
  795.         {
  796.         if(Curr_infile == Open_ifiles[i].i_fp)
  797.                 return(Open_ifiles[i].i_filename);
  798.  
  799.         }
  800.  
  801. INTERNAL_ERROR("seeing");
  802. return(NULL);
  803. }
  804.  
  805. Pseeing()
  806. {
  807. return(bind_string(1, get_input_name()));
  808. }
  809.  
  810. /**********************************************************************
  811.                                 (seen)
  812.  Close current infile.
  813. As in Edinburgh Prolog.
  814.  **********************************************************************/
  815. close_input(ifp)
  816. FILE *ifp;
  817. {
  818. int i;
  819.  
  820. if (ifp == stdin)
  821.    return 1;
  822.  
  823. for(i = 1; i < MAXOPEN; i++)
  824.    {
  825.    if(Curr_infile == Open_ifiles[i].i_fp){
  826.         fclose(Open_ifiles[i].i_fp);
  827.         Open_ifiles[i].i_fp = NULL;
  828.         Open_ifiles[i].i_filename = "";
  829.         Curr_infile = stdin;
  830.         return 1;
  831.         }
  832.    }
  833. INTERNAL_ERROR("close_input");
  834. return(0);/* for lint */
  835. }
  836.  
  837. Pseen()
  838. {
  839.         return(close_input(Curr_infile));
  840. }
  841.  
  842. /**********************************************************************
  843.                         (get <ascii_code:argument>)
  844.  Unifies the argument with the ascii code of the next char on
  845. Curr_infile.
  846. As in Edinburgh Prolog.
  847.  **********************************************************************/
  848. Pget()
  849. {
  850.         return(bind_int(1, (integer)getachar()));
  851. }
  852.  
  853. /**********************************************************************
  854.                         (consult <filename:atom>)
  855.                         (consult <filename:string>)
  856. As in Edinburgh Prolog (apart from consult user)
  857. ***********************************************************************/
  858. Pconsult()      /* load file                    */
  859. {
  860.         char *filename;
  861.  
  862.     if(!nth_arg(1))return(nargerr(1));
  863.  
  864.         if(NODEPTR_TYPE(DerefNode) == ATOM)
  865.         {
  866.                 filename = NODEPTR_ATOM(DerefNode)->name;
  867.         }
  868.         else
  869.                 if(NODEPTR_TYPE(DerefNode) == STRING)
  870.                 {
  871.                         filename = NODEPTR_STRING(DerefNode);
  872.                 }
  873.                 else
  874.                 {
  875.                         argerr(1, ATOMORSTRING);
  876.                         return(CRASH);
  877.                 }
  878.  
  879.         if(load(filename)) /* see prconsult.c */
  880.                 return(TRUE);
  881.         else
  882.                 return(FALSE);
  883. }
  884.  
  885. /**********************************************************************
  886.                         (listing)
  887.                         (listing <predicate:atom>)
  888. As in Edinburgh Prolog.
  889. ***********************************************************************/
  890. Plisting()              /* list clauses of predicate    */
  891. {
  892.         atom_ptr_t atomptr;
  893.  
  894.         if(IS_NIL(Arguments))
  895.         {
  896.                 do_listing();
  897.                 return(TRUE);
  898.         }
  899.         else
  900.         {
  901.                 ARG_ATOM(1, atomptr);
  902.                 pr_packet(ATOMPTR_CLAUSE(atomptr));
  903.                 return(TRUE);
  904.         }
  905. }
  906.  
  907. #if TRACE_CAPABILITY
  908. /**********************************************************************
  909.                         (trace)
  910. As in Edinburgh Prolog.
  911. ***********************************************************************/
  912. Ptrace()                /* turn trace on                */
  913. {
  914.         Trace_flag = 1;
  915.     Tracing_now = 1; /* added 12/25/91 */
  916.         return(TRUE);
  917. }
  918.  
  919. /**********************************************************************
  920.                         (notrace)
  921. As in Edinburgh Prolog.
  922. ***********************************************************************/
  923. Pnotrace()              /* turn trace off               */
  924. {
  925.         Trace_flag = 0;
  926.         return(TRUE);
  927. }
  928.  
  929. /**********************************************************************
  930.         reverse_trace_mode
  931.  Does not switch tracing on per se but when called all new frames
  932.  contain enough information so that reverse tracing is possible.
  933.  **********************************************************************/
  934. Preverse_trace()
  935. {
  936. extern int ReverseTraceMode;
  937. ReverseTraceMode = 1;
  938. return TRUE;
  939. }
  940.  
  941. /**********************************************************************
  942.          no_reverse_trace_mode
  943.  reverts to normal execution.
  944.  **********************************************************************/
  945. Pno_reverse_trace()
  946. {
  947. extern int ReverseTraceMode;
  948. ReverseTraceMode = 0;
  949. return TRUE;
  950. }
  951.  
  952. /*******************************************************************************
  953.                         (suspend_trace)
  954.  Unactivate trace.
  955.  *******************************************************************************/
  956.  
  957. Psuspend_trace()
  958. {
  959.         Trace_flag--;
  960.         return 1;
  961. }
  962.  
  963. /******************************************************************************
  964.                         (resume_trace)
  965.  Return to trace state that existed at last call of suspend_trace
  966.  You might want to make use of statements of the form 
  967.     if(Trace_flag > 1)....
  968.  ******************************************************************************/
  969. Presume_trace()
  970. {
  971.         Trace_flag++;
  972.         return 1;
  973. }
  974.  
  975. /******************************************************************************
  976.                         (logging <log_file:string>)
  977.  Record all screen io on a designated file.
  978.  *****************************************************************************/
  979. FILE *Log_file;
  980.  
  981. Plogging()
  982. {
  983.         char *log_filename;
  984.  
  985.         ARG_STRING(1, log_filename);
  986.         if((Log_file = fopen(log_filename, "w")) == NULL)
  987.         {
  988.                 sprintf(Print_buffer, CANTOPEN, log_filename);
  989.                 errmsg(Print_buffer);
  990.                 return 0;
  991.         }
  992.         else
  993.                 return 1;
  994. }
  995.  
  996. /******************************************************************************
  997.                         (nologging)
  998.  Closes the logging file, turns logging off.
  999.  *****************************************************************************/
  1000. Pnologging()
  1001. {
  1002.         if(Log_file != NULL)
  1003.                 fclose(Log_file);
  1004.         Log_file = NULL;
  1005.         return 1;
  1006.  
  1007. }
  1008.  
  1009. #endif
  1010.  
  1011.  
  1012. /******************************************************************************
  1013.                         (interned <input_string:string> <corresponding_atom:atom>)
  1014.                         (interned <input_string:string> <corresponding_atom:variable>)
  1015.  Succeeds iff the string is the name of an atom.
  1016.  Unifies the second argument with this atom if success.
  1017.  ******************************************************************************/
  1018. Pinterned()
  1019. {
  1020.         atom_ptr_t the_atom, hash_search();
  1021.         char *s;
  1022.  
  1023.         ARG_STRING(1, s);
  1024.         the_atom = hash_search(s);
  1025.  
  1026.         if( the_atom == NULL)
  1027.                 return(0);
  1028.         else
  1029.                 return(bind_atom(2, the_atom));
  1030. }
  1031.  
  1032. /**********************************************************************
  1033.                         (first_predicate <predicate:atom>)
  1034.                         (first_predicate <predicate:variable>)
  1035. Unifies the argument with the first predicate defined by
  1036. the user or in sprolog.ini .
  1037.  **********************************************************************/
  1038. Pfirst_predicate()
  1039. {
  1040.         extern pred_rec_ptr_t First_pred;
  1041.         return(bind_atom(1, First_pred->atom));
  1042. }
  1043.  
  1044. /***********************************************************************
  1045.                         (next_predicate <predicate:atom> <predicate:variable>)
  1046.                         (next_predicate <predicate:atom> <predicate:atom>)
  1047.  Unifies the second argument with the predicate that follows the
  1048.  first argument , if there is one and fails otherwise.
  1049.  Owing to the fact we didnt give the interpreter explicit access to 
  1050.  the predicate record pointer this builtin is rather slow.
  1051.  ***********************************************************************/
  1052. Pnext_predicate()
  1053. {
  1054.         extern pred_rec_ptr_t First_pred;
  1055.         pred_rec_ptr_t predrptr;
  1056.         atom_ptr_t atomptr;
  1057.  
  1058.         ARG_ATOM(1, atomptr);
  1059.  
  1060.         for(predrptr = First_pred; predrptr != NULL; predrptr = predrptr->next_pred)
  1061.                 if(predrptr->atom == atomptr)break;
  1062.  
  1063.         if(predrptr == NULL)return 0;
  1064.         else
  1065.                 do{
  1066.                         predrptr = predrptr->next_pred;
  1067.                         if(predrptr == NULL)return(0);
  1068.                         atomptr = predrptr->atom;
  1069.                 }while( atomptr && !ATOMPTR_CLAUSE(atomptr));
  1070.  
  1071.         if(!atomptr)return 0;
  1072.         else
  1073.                 return(bind_atom(2, atomptr));
  1074. }
  1075.  
  1076. /**********************************************************************
  1077.                         (builtin <predicate:atom>)
  1078. Succeeds if argument is a builtin predicate. 
  1079. **********************************************************************/
  1080. Pbuiltin()
  1081. {
  1082.         atom_ptr_t atomptr;
  1083.         ARG_ATOM(1, atomptr);
  1084.  
  1085.         return(atomptr <= LastBuiltin);
  1086. }
  1087.  
  1088. /**********************************************************************
  1089.                         (first_clause <predicate:atom><variable>)
  1090. Unifies the second argument with the first clause of the predicate
  1091. if one exists and fails otherwise.
  1092. ***********************************************************************/
  1093. Pfirst_clause()
  1094. {
  1095.         atom_ptr_t atomptr;
  1096.  
  1097.         ARG_ATOM(1, atomptr);
  1098.         if(IS_BUILTIN(atomptr))
  1099.         {
  1100.                 return(0);
  1101.         }
  1102.         if(ATOMPTR_CLAUSE(atomptr) == NULL)
  1103.                 return(0);
  1104.         else
  1105.                 return(bind_clause(2, ATOMPTR_CLAUSE(atomptr)));
  1106. }
  1107.  
  1108. /**********************************************************************
  1109.       (next_clause <(bound) variable:clause><(bound)variable:clause>)
  1110. Unifies the second argument with the clause after the first argument if one exists
  1111. and fails otherwise.
  1112. ***********************************************************************/
  1113. Pnext_clause()
  1114. {
  1115.         clause_ptr_t clause1ptr, clause2ptr;
  1116.  
  1117.         ARG_CLAUSE(1, clause1ptr);
  1118.         clause2ptr = CLAUSEPTR_NEXT(clause1ptr);
  1119.  
  1120.         if(clause2ptr == NULL)
  1121.                 return(FAIL);
  1122.  
  1123.         return(bind_clause(2, clause2ptr));
  1124. }
  1125. /**********************************************************************
  1126.                 (body_clause <(bound) variable:clause> <output_body:variable>)
  1127. You need this to get at the list which is the body of the clause.
  1128. See how the "clause" predicate is defined in sprolog.ini.
  1129. ***********************************************************************/
  1130. Pbody_clause()
  1131. {
  1132.         pair_ptr_t pairptr, get_pair();
  1133.         clause_ptr_t clauseptr;
  1134.         subst_ptr_t my_Subst_alloc();
  1135.         node_ptr_t nodeptr, get_node();
  1136.  
  1137.         ARG_CLAUSE(1, clauseptr);
  1138.  
  1139.         pairptr = get_pair(DYNAMIC);
  1140.         nodeptr = PAIRPTR_HEAD(pairptr);
  1141.         NODEPTR_TYPE(nodeptr) = PAIR;
  1142.         NODEPTR_PAIR(nodeptr) = NODEPTR_PAIR(CLAUSEPTR_HEAD(clauseptr));
  1143.  
  1144.         nodeptr = PAIRPTR_TAIL(pairptr);
  1145.         if(IS_FACT(clauseptr))
  1146.         {
  1147.                 NODEPTR_TYPE(nodeptr) = ATOM;
  1148.                 NODEPTR_ATOM(nodeptr) = Nil;
  1149.         }
  1150.         else
  1151.         {
  1152.                 NODEPTR_TYPE(nodeptr) = PAIR;
  1153.                 NODEPTR_PAIR(nodeptr) = NODEPTR_PAIR(CLAUSEPTR_GOALS(clauseptr));
  1154.         }
  1155.         nodeptr = get_node(DYNAMIC);
  1156.         NODEPTR_TYPE(nodeptr) = PAIR;
  1157.         NODEPTR_PAIR(nodeptr) = pairptr;
  1158.  
  1159.         nth_arg(2);
  1160.         return(unify(DerefNode, DerefSubst,
  1161.             nodeptr, my_Subst_alloc((unsigned int)CLAUSEPTR_NVARS(clauseptr))));
  1162. }
  1163.  
  1164. /*****************************************************************************
  1165.                         (read_word <output_word:variable>)
  1166.                         (read_word <output_word:string>)
  1167.  Reads a string. 
  1168.  The use of fscanf would have been too rudimentary.
  1169.  *****************************************************************************/
  1170.  
  1171. Pread_word()
  1172. {
  1173.         extern char *Read_buffer;
  1174.     extern int Ch;
  1175.     char *s;
  1176.  
  1177.     s = Read_buffer;
  1178.     
  1179.     do{
  1180.       getachar();
  1181.  
  1182.       if(Ch == EOF)
  1183.              {
  1184.         return(0);
  1185.           }
  1186.       else
  1187.       if(isspace(Ch))
  1188.         {
  1189.         continue;
  1190.         }
  1191.       else
  1192.       *s++ = Ch;
  1193.       break;
  1194.       }while(1);
  1195.  
  1196.     do{
  1197.       getachar();
  1198.  
  1199.       if(Ch == EOF)
  1200.              {
  1201.         return(0);
  1202.           }
  1203.       else
  1204.       if(isspace(Ch))
  1205.         {
  1206.         *s = '\0';
  1207.         break;
  1208.         }
  1209.       else
  1210.       *s++ = Ch;
  1211.       }while(1);
  1212.  
  1213.         return(bind_string(1, Read_buffer));
  1214. }
  1215.  
  1216. /**********************************************************************
  1217.                         (read <term_read:argument>)
  1218. Read a prolog object. If you want to access the variable names
  1219. then do it with var_name before the next call to this or to a consult.
  1220. ***********************************************************************/
  1221. Pread()
  1222. {
  1223.         extern varindx Nvars;
  1224.         node_ptr_t node2ptr, get_node(), parse();
  1225.  
  1226.         if(!nth_arg(1))return(CRASH);
  1227.         ini_parse();
  1228.  
  1229.         node2ptr = get_node(DYNAMIC);
  1230.         if(parse(FALSE, DYNAMIC, node2ptr) == NULL)
  1231.                 return(0);
  1232.         unify(DerefNode, DerefSubst, node2ptr, my_Subst_alloc((unsigned int)Nvars*sizeof(struct subst)));
  1233.         return(1);
  1234. }
  1235.  
  1236. /******************************************************************************
  1237.                         (var_offset <tested:variable><offset:variable>)
  1238.                         (var_offset <tested:variable><offset:integer>)
  1239.  The second argument is unified with the "offset" of the first
  1240.  argument. 
  1241.  This could be used for metaprogramming.
  1242.  ******************************************************************************/
  1243. Pvar_offset()
  1244. {
  1245.         node_ptr_t nodeptr;
  1246.         integer corrected_offset;
  1247.  
  1248.         ARG_VAR(1, nodeptr);
  1249.         corrected_offset = NODEPTR_OFFSET(nodeptr)/sizeof(struct subst);
  1250.         return(bind_int(2, corrected_offset));
  1251. }
  1252.  
  1253.  
  1254. /**********************************************************************
  1255.                 (var_name <index:integer> <name:variable>)
  1256.                 (var_name <index:integer> <name:variable>)
  1257. This extracts the nth name in the table of variable names that 
  1258. is temporarily created after a parse.
  1259. It fails if the first argument is greater than the number of
  1260. available variables.
  1261. It can be used if you want to keep the names of the variables in 
  1262. some way.
  1263. See the file xread.pro
  1264.  *********************************************************************/
  1265. Pvar_name()
  1266. {
  1267.     varindx i;
  1268.     char *var_name(), *s;/* from prparse.c */
  1269.  
  1270.         ARG_INT(1, i);
  1271.  
  1272.         s = var_name(i);
  1273.  
  1274.         if(s == NULL)return(0);
  1275.  
  1276.         return(bind_string(2, s));
  1277. }
  1278.  
  1279.  
  1280.  
  1281.  
  1282.  
  1283. #if 0/* There is a bug here, we can implement this in prolog  
  1284.       * This has been done in sprolog.ini
  1285.       */
  1286. Pallfacts()             /* allfacts(Template, List_of_these) (io) */
  1287. {
  1288.         extern subst_ptr_t Subst_ptr, Subst_mem;
  1289.         extern node_ptr_t NilNodeptr, get_node();
  1290.         extern node_ptr_t ** Trail_ptr;
  1291.         node_ptr_t **trail1ptr;
  1292.         integer count;
  1293.         atom_ptr_t predicate;
  1294.         node_ptr_t the_head, the_tail, nodeptr, template, second_arg;
  1295.         pair_ptr_t pairptr, get_pair();
  1296.         clause_ptr_t clauseptr;
  1297.         subst_ptr_t subst1ptr, subst2ptr;
  1298.  
  1299.         template = FIRST_ARG();
  1300.         count = 0;
  1301.         the_head = NODEPTR_HEAD(template);
  1302.         predicate = NODEPTR_ATOM(the_head);
  1303.  
  1304.         if(IS_BUILTIN(predicate))
  1305.         {
  1306.                 return(0);
  1307.         }
  1308.  
  1309.         clauseptr = ATOMPTR_CLAUSE(predicate);
  1310.  
  1311.         nodeptr = get_node(DYNAMIC);
  1312.         NODEPTR_TYPE(nodeptr) = PAIR;
  1313.         pairptr = get_pair(DYNAMIC);
  1314.         NODEPTR_PAIR(nodeptr) = pairptr;
  1315.         the_head = NODEPTR_HEAD(nodeptr);
  1316.         the_tail = NODEPTR_TAIL(nodeptr);
  1317.         NODEPTR_TYPE(the_head) = VAR;
  1318.         NODEPTR_OFFSET(the_head) = 0;
  1319.         NODEPTR_TYPE(the_tail) = VAR;
  1320.         NODEPTR_OFFSET(the_tail) = sizeof(struct subst);
  1321.  
  1322.         while(clauseptr)
  1323.         {
  1324.                 if(!IS_FACT(clauseptr)){
  1325.                         clauseptr = CLAUSEPTR_NEXT(clauseptr);
  1326.                         continue;
  1327.                 }
  1328.                 subst1ptr = Subst_ptr;
  1329.                 trail1ptr = Trail_ptr;
  1330.                 my_Subst_alloc((unsigned int)CLAUSEPTR_NVARS(clauseptr));
  1331.                 if(!unify(NODEPTR_TAIL(CLAUSEPTR_HEAD(clauseptr)), subst1ptr, 
  1332.                     NODEPTR_TAIL(template), DerefSubst))
  1333.                 {
  1334.                         reset_trail(trail1ptr);
  1335.                         Subst_ptr = subst1ptr;
  1336.                         clauseptr = CLAUSEPTR_NEXT(clauseptr);
  1337.                         continue;
  1338.                 }
  1339.                 else/* unification successful */
  1340.                 {
  1341.                         count++;
  1342.                         clauseptr = CLAUSEPTR_NEXT(clauseptr);
  1343.                         subst2ptr = Subst_ptr;
  1344.                         my_Subst_alloc((unsigned int)2*sizeof(struct subst));
  1345.                         if(count == 1){
  1346.                                 bind_var(the_head, subst2ptr, 
  1347.                                     CLAUSEPTR_HEAD(clauseptr), subst1ptr);
  1348.                                 bind_var(the_tail, subst2ptr, 
  1349.                                     NilNodeptr, subst1ptr);
  1350.                         }
  1351.                         else{
  1352.                                 bind_var(the_head, subst2ptr, 
  1353.                                     CLAUSEPTR_HEAD(clauseptr), subst1ptr);
  1354.                                 bind_var(the_tail, subst2ptr,
  1355.                                     nodeptr, subst1ptr);
  1356.                         }
  1357.                 }
  1358.         }
  1359.         second_arg = nth_arg(2);
  1360.         if(count)
  1361.         {
  1362.  
  1363.                 return(unify(second_arg, DerefSubst, nodeptr, subst2ptr));
  1364.         }
  1365.         else
  1366.                 return(unify(second_arg, DerefSubst, NilNodeptr, Subst_mem));
  1367. }
  1368. #endif
  1369.  
  1370. /**********************************************************************
  1371.                         (assertz <clause_body:list>)
  1372. Adds a new clause to the end of its packet.
  1373. As in Edinburgh Prolog.
  1374. ***********************************************************************/
  1375. Passertz()
  1376. {
  1377.         if(!nth_arg(1))return(CRASH);
  1378.  
  1379.         if(!do_assertz(PERMANENT, DerefNode, DerefSubst))
  1380.                 return(CRASH);
  1381.         else
  1382.                 return(TRUE);
  1383. }
  1384.  
  1385.  
  1386. /**********************************************************************
  1387.                         (asserta <clause_body:list>)
  1388.                         (asserta <clause_body:list> <index:integer>)
  1389. Exxtension of Edinburgh Prolog.
  1390. Adds a new clause to the beginning of its packet - unless there
  1391. is a 2nd argument which indicates the position in which the clause
  1392. is added.
  1393. ***********************************************************************/
  1394. Passerta()
  1395. {
  1396.         node_ptr_t body;
  1397.         subst_ptr_t body_substptr;
  1398.  
  1399.         if(!nth_arg(1))
  1400.                 return(CRASH);
  1401.  
  1402.         body = DerefNode;
  1403.         body_substptr = DerefSubst;
  1404.  
  1405.         if(!nth_arg(2))
  1406.         {
  1407.                 if(!do_asserta(PERMANENT, body, body_substptr))
  1408.                         return(CRASH);
  1409.         }
  1410.         else
  1411.         {
  1412.                 integer n;
  1413.  
  1414.                 ARG_INT(2, n);
  1415.                 if(!do_assertn(PERMANENT, body, body_substptr, n))
  1416.                         return 0;
  1417.         }
  1418.         return(TRUE);
  1419.  
  1420. }
  1421.  
  1422.  
  1423. /**********************************************************************
  1424.                         (temp_assertz <clause_body:list>)
  1425. Adds a new clause to the end of its packet.
  1426. But in temporary zone.
  1427. This will seem identical to temp_assertz and may be freely intermixed
  1428. - the only difference being that clean_temp removes those clauses
  1429. added by temp_assertz (as if they had been marked).
  1430. ***********************************************************************/
  1431. Ptemp_assertz()
  1432. {
  1433.         if(!nth_arg(1))return(CRASH);
  1434.  
  1435.         if(!do_assertz(TEMPORARY, DerefNode, DerefSubst))
  1436.                 return(CRASH);
  1437.         else
  1438.                 return(TRUE);
  1439. }
  1440.  
  1441. /**********************************************************************
  1442.                         (temp_asserta <clause_body:list>)
  1443.                         (temp_asserta <clause_body:list> <index:integer>)
  1444. Adds a new clause to the beginning of its packet.
  1445. But in temporary zone.
  1446. The existence of a second argument implies the clause is inserted as nth
  1447. ***********************************************************************/
  1448. Ptemp_asserta()
  1449. {
  1450.         node_ptr_t body;
  1451.         subst_ptr_t body_substptr;
  1452.  
  1453.         if(!nth_arg(1))return(CRASH);
  1454.  
  1455.         body = DerefNode;
  1456.         body_substptr = DerefSubst;
  1457.  
  1458.         if(!nth_arg(2))
  1459.         {
  1460.                 if(!do_asserta(TEMPORARY, body, body_substptr))
  1461.                         return(CRASH);
  1462.         }
  1463.         else
  1464.         {
  1465.                 integer n;
  1466.  
  1467.                 ARG_INT(2, n);
  1468.                 if(!do_assertn(TEMPORARY, body, body_substptr, n))
  1469.                         return 0;
  1470.         }
  1471.         return(TRUE);
  1472. }
  1473.  
  1474. /***********************************************************************
  1475.                         (remove_clause <bound variable:clause>)
  1476.  ***********************************************************************/
  1477. Premove_clause()
  1478. {
  1479.         atom_ptr_t atomptr;
  1480.         clause_ptr_t clauseptr;
  1481.         node_ptr_t headptr;
  1482.  
  1483.         ARG_CLAUSE(1, clauseptr);
  1484.         headptr = CLAUSEPTR_HEAD(clauseptr);
  1485.         atomptr = NODEPTR_ATOM(NODEPTR_HEAD(headptr));
  1486.         return(remove_clause(atomptr, clauseptr));
  1487. }
  1488.  
  1489. /**********************************************************************
  1490.                         (clean_temp )
  1491. Clean the temporary zone;
  1492. ***********************************************************************/
  1493. Pclean_temp()
  1494. {
  1495.         clean_temp(); /* see pralloc.c */
  1496.         return(1);
  1497. }
  1498.  
  1499. #ifdef CLOCK
  1500. /********************************************************************
  1501.                 (clock <output_seconds:variable>)
  1502. Counts microseconds elapsed since first call of clock.
  1503.  ************************************************************************/
  1504. Pclock()
  1505. {
  1506.         long clock();
  1507.         return(bind_int(1, (integer)clock()));
  1508. }
  1509. #endif
  1510.  
  1511. /**********************************************************************
  1512.                 (n_unifications <output_count:variable>)
  1513.  Counts number of unifications
  1514.  ************************************************************************/
  1515. Pn_unifications()
  1516. {
  1517.         extern integer Nunifications;
  1518.         return(bind_int(1, Nunifications));
  1519. }
  1520.  
  1521. /**********************************************************************
  1522.                 (string_from <input:integer> <variable or string>)
  1523.                 (string_from <input:real> <variable or string>)
  1524.                 (string_from <input:atom> <variable or string>)
  1525.                 (string_from <input:string> <variable or string>)
  1526. Extracts a copy of the string that looks like the print representation
  1527. of the object.
  1528.  ************************************************************************/
  1529. Pstring_from()
  1530. {
  1531.         long offset_subst();
  1532.         node_ptr_t nodeptr;
  1533.  
  1534.         nodeptr = nth_arg(1);
  1535.  
  1536.         if(!nodeptr)
  1537.                 return(nargerr(1));
  1538.  
  1539.  
  1540.         switch(NODEPTR_TYPE(nodeptr))
  1541.         {
  1542.         case ATOM:
  1543.                 return(bind_string(2, ATOMPTR_NAME(NODEPTR_ATOM(nodeptr))));
  1544.         case INT:
  1545.                 sprintf(Print_buffer, "%ld", NODEPTR_INT(nodeptr));
  1546.                 return(bind_string(2, Print_buffer));
  1547. #ifdef REAL
  1548.         case REAL:
  1549.                 sprintf(Print_buffer, "%ld", NODEPTR_INT(nodeptr));
  1550.                 return(bind_string(2, Print_buffer));
  1551. #endif
  1552.         case STRING:
  1553.                 return(bind_string(2, NODEPTR_STRING(nodeptr)));
  1554.         case VAR:
  1555.                 sprintf(Print_buffer, "_%d_%ld", NODEPTR_OFFSET(nodeptr)/sizeof(struct subst),
  1556.                     offset_subst(DerefSubst));
  1557.                 return(bind_string(2, Print_buffer));
  1558.         default:
  1559.                 return(0);
  1560.         }
  1561. }
  1562.  
  1563. /************************************************************************
  1564.                         (string_length <input:string> <variable>)
  1565.                         (string_length <input:string> <integer>)
  1566.  ************************************************************************/
  1567. Pstring_length()
  1568. {
  1569.         char *s;
  1570.  
  1571.         ARG_STRING(1, s);
  1572.         return(bind_int(2, (integer)strlen(s)));
  1573. }
  1574.  
  1575. #ifdef CHARACTER
  1576. /************************************************************************
  1577.                         (string_nth <index:integer> <string> <output:variable>)
  1578.                         (string_nth <index:integer> <string> <output:char>)
  1579. Extract  the nth char of the string.
  1580. ************************************************************************/
  1581. Pstring_nth()
  1582. {
  1583.         char *s;
  1584.         int i;
  1585.  
  1586.         ARG_INT(1, i);
  1587.         if( i < 0)
  1588.           return 0;
  1589.         ARG_STRING(2, s);
  1590.         return(bind_character(3, s[i - 1]));
  1591. }
  1592.  
  1593. #else
  1594. /************************************************************************
  1595.                         (string_nth <index:integer> <string> <output:variable>)
  1596.                         (string_nth <index:integer> <string> <output:integer>)
  1597. Extract the ascii code of the nth char of the string.
  1598. ************************************************************************/
  1599. Pstring_nth()
  1600. {
  1601.         char *s;
  1602.         int i;
  1603.  
  1604.         ARG_INT(1, i);
  1605.         if( i < 0)
  1606.           return 0;
  1607.         ARG_STRING(2, s);
  1608.         return(bind_int(3, (integer)s[i - 1]));
  1609. }
  1610. #endif
  1611.  
  1612. /******************************************************************************
  1613.                         (string_concat <input:string><input:string><output:string>)
  1614.                         (string_concat <string><string><variable>)
  1615.  The third argument is the concatenation of the first two.
  1616.  ******************************************************************************/
  1617. Pstring_concat()
  1618. {
  1619.         char *s, *s1, *s2;
  1620.  
  1621.         ARG_STRING(1, s1);
  1622.         ARG_STRING(2, s2);
  1623.  
  1624.         s = get_string((my_alloc_size_t)(strlen(s1)+ strlen(s2)+1), DYNAMIC);
  1625.         *s = '\0';
  1626.         strcat(s, s1);
  1627.         strcat(s, s2);
  1628.         return(bind_string(3, s));
  1629. }
  1630.  
  1631. /******************************************************************************
  1632.                         (string_suffix <index:integer><input:string><output:string>)
  1633.                         (string_suffix <index:integer><input:string><output:variable>)
  1634.  The third argument is the suffix of the second from position given by the
  1635.  first argument
  1636.  ******************************************************************************/
  1637. Pstring_suffix()
  1638. {
  1639.         char *s;
  1640.         integer offset;
  1641.         
  1642.         ARG_INT(1, offset);
  1643.         if ( offset < 1 )return 0;
  1644.         ARG_STRING(2, s);
  1645.         return(bind_string(3, s + (offset - 1) ));
  1646. }
  1647.  
  1648. /************************************************************************
  1649.         (space_left <var> <var> <var> <var> <var> <var>)
  1650.  Returns space left in each zone. (see sprolog.inf)
  1651.  ************************************************************************/
  1652. Pspace_left()
  1653. {
  1654.         zone_size_t h, str, d, su, tr, te;
  1655.  
  1656.         space_left(&h, &str, &d, &su, &tr, &te);
  1657.         if(bind_int(1, (integer)h) == CRASH)return(CRASH);
  1658.         if(bind_int(2, (integer)str) == CRASH)return(CRASH);
  1659.         if(bind_int(3, (integer)d) == CRASH)return(CRASH);
  1660.         if(bind_int(4, (integer)su) == CRASH)return(CRASH);
  1661.         if(bind_int(5, (integer)tr) == CRASH)return(CRASH);
  1662.         if(bind_int(6, (integer)te) == CRASH)return(CRASH);
  1663.         return(1);
  1664. }
  1665. /*****************************************************************************
  1666.             Pconsumption()
  1667.  Just to see how much room things occupy.
  1668.  ******************************************************************************/
  1669.  
  1670. #ifdef STATISTICS 
  1671. Pconsumption()
  1672. {
  1673.         extern zone_size_t  Atom_consumption,
  1674.         Pair_consumption,
  1675. #ifdef REAL
  1676.         Real_consumption,
  1677. #endif
  1678.         Node_consumption,
  1679.         Clause_consumption,
  1680.         String_consumption,
  1681.         Predrec_consumption;
  1682.         sprintf(Print_buffer, "Atom %ld Pair %ld Real %ld Node %ld Clause %ld String %ld Predrec %ld \n", 
  1683.             Atom_consumption,
  1684.             Pair_consumption,
  1685. #ifdef REAL
  1686.             Real_consumption,
  1687. #else
  1688.             0L,
  1689. #endif
  1690.             Node_consumption,
  1691.             Clause_consumption,
  1692.             String_consumption,
  1693.             Predrec_consumption);
  1694.         pr_string(Print_buffer);
  1695. }
  1696. #endif
  1697. #ifdef HUNTBUGS
  1698. /* see prdebug.c */
  1699. Pbughunt()
  1700. {
  1701.     extern int Bug_hunt_flag;
  1702.  
  1703.     Bug_hunt_flag = 1;
  1704.     return 1;
  1705. }
  1706. #endif
  1707. #ifdef RANDOM1
  1708. /************************************************************************
  1709.  *            (random_decision)                *
  1710.  * succeed or fail randomly                         *
  1711.  * My Unix rand() function is not very random
  1712.  ************************************************************************/
  1713. Prandom_decision()
  1714. {
  1715. extern int rand();
  1716. #ifdef CLOCK
  1717. return(((clock()+rand()/4) % 2)? TRUE: FALSE);/* try to make it more random */
  1718. #else
  1719. return(((rand()) % 2)? TRUE: FALSE);
  1720. #endif
  1721. }
  1722. #endif
  1723. /**************************************************************************
  1724.          (random <output:variable> <limit:integer>)
  1725.  Returns a random integer less than or equal to the limit.
  1726.  ****************************************************************************/
  1727. Prand()
  1728. {
  1729. integer limit, randnum;
  1730.  
  1731. ARG_INT(2, limit);
  1732.  
  1733. randnum = (integer)rand() % (limit + 1);
  1734. return(bind_int(1, randnum));
  1735. }
  1736. /*--------------------------------------------------------------------*/
  1737. /**********************************************************************
  1738.                 ini_builtin()
  1739. This is where you let Small Prolog know it has builtins.
  1740. Of course you could add a similar function, say ini_extra
  1741. for extra builtins in a separate file so you dont have to 
  1742. recompile this one every time.
  1743. ***********************************************************************/
  1744. void ini_builtin()
  1745. {
  1746.         ini_named_files();
  1747.         make_builtin(Ptell,     "tell");
  1748.         make_builtin(Ptelling,     "telling");
  1749.         make_builtin(Pseeing,     "seeing");
  1750.         make_builtin(Ptold,     "told");
  1751.         make_builtin(Pdisplay,     "display");
  1752.         make_builtin(Pwrites,     "writes");
  1753.         make_builtin(Pnl,     "nl");
  1754.         make_builtin(Pput,     "put");
  1755.         make_builtin(Pfail,     "fail");
  1756.         make_builtin(Pabort,     "abort");
  1757.         make_builtin(Pquit,     "quit");
  1758.         make_builtin(Prepeat,     "repeat");
  1759.     make_builtin(Pgennum,    "gennum");
  1760.         make_builtin(Pcut,     "cut");
  1761.         make_builtin(Pconsult,     "consult");
  1762.         make_builtin(Psee,     "see");
  1763.         make_builtin(Pseen,     "seen");
  1764.         make_builtin(Plisting,     "listing");
  1765. #if TRACE_CAPABILITY
  1766.         make_builtin(Ptrace,     "trace");
  1767.         make_builtin(Pnotrace,     "notrace");
  1768.         make_builtin(Psuspend_trace, "suspend_trace");
  1769.         make_builtin(Presume_trace, "resume_trace");
  1770.         make_builtin(Preverse_trace, "reverse_trace_mode");
  1771.         make_builtin(Pno_reverse_trace, "no_reverse_trace_mode");
  1772.  
  1773. #endif
  1774. #ifdef LOGGING_CAPABILITY
  1775.         make_builtin(Plogging, "logging");
  1776.         make_builtin(Pnologging, "nologging");
  1777. #endif
  1778.         make_builtin(Pinteger,     "integer");
  1779.         make_builtin(Patom,     "atom");
  1780.         make_builtin(Pinterned, "interned");
  1781.         make_builtin(Pvar,     "var");
  1782.         make_builtin(Pnonvar,     "nonvar");
  1783.         make_builtin(Patomic,     "atomic");
  1784. #ifdef REAL
  1785.         make_builtin(Preal,     "real");
  1786. #endif
  1787.         make_builtin(Pstring,     "string");
  1788.         make_builtin(Pbuiltin,     "builtin");
  1789.         make_builtin(Pstring_from, "string_from");
  1790.         make_builtin(Pstring_length, "string_length");
  1791.         make_builtin(Pstring_nth, "string_nth");
  1792.         make_builtin(Pstring_concat, "string_concat");
  1793.         make_builtin(Pstring_suffix, "string_suffix");
  1794. #ifdef REAL
  1795.         make_builtin(Prplus,     "rplus");
  1796.         make_builtin(Prless,     "rless");
  1797. #endif
  1798.         make_builtin(Piplus,     "iplus");
  1799.         make_builtin(Piminus,     "iminus");
  1800.         make_builtin(Pimult,     "imult");
  1801.         make_builtin(Piless,     "iless");
  1802.         make_builtin(Pileq, "ileq");
  1803.         make_builtin(Pimodify, "imodify");
  1804.         /*      make_builtin(Pallfacts, "allfacts"); */
  1805.         make_builtin(Pbody_clause, "body_clause");
  1806.         make_builtin(Pfirst_clause, "first_clause");
  1807.         make_builtin(Pnext_clause, "next_clause");
  1808.         make_builtin(Pvar_offset, "var_offset");
  1809.         make_builtin(Pvar_name, "var_name");
  1810.         make_builtin(Pfirst_predicate, "first_predicate");
  1811.         make_builtin(Pnext_predicate, "next_predicate");
  1812.         make_builtin(Passerta, "asserta");
  1813.         make_builtin(Passertz, "assertz");
  1814.         make_builtin(Ptemp_asserta, "temp_asserta");
  1815.         make_builtin(Ptemp_assertz, "temp_assertz");
  1816.         make_builtin(Premove_clause, "remove_clause");
  1817.         make_builtin(Pclean_temp, "clean_temp");
  1818.         make_builtin(Pread,     "read");
  1819.         make_builtin(Pread_word, "read_word");
  1820.         make_builtin(Pget,     "get");
  1821. #ifdef CLOCK
  1822.         make_builtin(Pclock,     "clock");
  1823. #endif
  1824.         make_builtin(Pn_unifications, "n_unifications");
  1825.         make_builtin(Pspace_left, "space_left");
  1826. #ifdef STATISTICS
  1827.         make_builtin(Pconsumption, "consumption");
  1828. #endif
  1829. #ifdef HUNTBUGS
  1830.     make_builtin(Pbughunt,"bughunt");
  1831. #endif
  1832. #ifdef RANDOM1 
  1833.     make_builtin(Prandom_decision, "random_decision");
  1834. #endif
  1835.     make_builtin(Prand,     "rand");
  1836. /* Put     ini_extra(); here for your builtins  and put them in a separate file
  1837.  * This one is too big.
  1838.  */
  1839. }
  1840.  
  1841. /* end of file */
  1842.