home *** CD-ROM | disk | FTP | other *** search
/ The World of Computer Software / World_Of_Computer_Software-02-387-Vol-3of3.iso / p / plbin.zip / pl / src / pl-prims.c < prev    next >
C/C++ Source or Header  |  1993-02-23  |  29KB  |  1,522 lines
  1. /*  pl-prims.c,v 1.2 1993/02/23 13:16:41 jan Exp
  2.  
  3.     Copyright (c) 1990 Jan Wielemaker. All rights reserved.
  4.     See ../LICENCE to find out about your rights.
  5.     jan@swi.psy.uva.nl
  6.  
  7.     Purpose: primitive built in
  8. */
  9.  
  10. #include "pl-incl.h"
  11. #include "pl-ctype.h"
  12.  
  13. forwards int    pl_se P((Word, Word, int));
  14. forwards void    resetVariables P((Word));
  15. forwards bool    freeVariables P((Word, Word *, bool));
  16. forwards char     *prependBase P((int, char *));
  17. forwards bool    isPrefix P((char *, char *));
  18. forwards bool    boolPlease P((bool *, Word, Word));
  19. forwards word    copyTerm P((Word, Table));
  20.  
  21.         /********************************
  22.         *         TYPE CHECKING         *
  23.         *********************************/
  24.  
  25.  
  26. word
  27. pl_nonvar(k)
  28. register Word k;
  29. { if (isVar(*k))
  30.     fail;
  31.  
  32.   succeed;
  33. }
  34.  
  35. word
  36. pl_var(k)
  37. register Word k;
  38. { if (isVar(*k))
  39.     succeed;
  40.  
  41.   fail;
  42. }
  43.  
  44. word
  45. pl_integer(k)
  46. register Word k;
  47. { if (isInteger(*k))
  48.     succeed;
  49.  
  50.   fail;
  51. }
  52.  
  53. word
  54. pl_float(k)
  55. register Word k;
  56. { if (isReal(*k))
  57.     succeed;
  58.  
  59.   fail;
  60. }
  61.  
  62. #if O_STRING
  63. word
  64. pl_string(k)
  65. register Word k;
  66. { if (isString(*k))
  67.     succeed;;
  68.  
  69.   fail;
  70. }
  71. #endif /* O_STRING */
  72.  
  73. word
  74. pl_number(k)
  75. register Word k;
  76. { if ( isNumber(*k) )
  77.     succeed;
  78.  
  79.   fail;
  80. }
  81.  
  82. word
  83. pl_atom(k)
  84. register Word k;
  85. { if (isAtom(*k))
  86.     succeed;
  87.  
  88.   fail;
  89. }
  90.  
  91. word
  92. pl_atomic(k)
  93. register Word k;
  94. { if (isAtomic(*k))
  95.     succeed;
  96.  
  97.   fail;
  98. }
  99.  
  100. word
  101. pl_ground(term)
  102. register Word term;
  103. { register int arity;
  104.  
  105.   deRef(term);
  106.  
  107.   if (isVar(*term) )
  108.     fail;
  109.   if (!isTerm(*term) )
  110.     succeed;
  111.   arity = functorTerm(*term)->arity;
  112.   for(term = argTermP(*term, 0); arity > 0; arity--, term++)
  113.     TRY( pl_ground(term) );
  114.  
  115.   succeed;
  116. }
  117.  
  118.         /********************************
  119.         *           EQUALITY            *
  120.         *********************************/
  121.  
  122. word
  123. pl_unify(t1, t2)            /* =/2 */
  124. register Word t1, t2;
  125. { mark m;
  126.  
  127.   Mark(m);
  128.   if (unify(t1, t2) == FALSE)
  129.   { Undo(m);
  130.     fail;
  131.   }
  132.  
  133.   succeed;  
  134. }
  135.  
  136. word
  137. pl_notunify(t1, t2)
  138. register Word t1, t2;
  139. { bool rval;
  140.   mark m;
  141.   
  142.   Mark(m);
  143.   rval = unify(t1, t2);
  144.   Undo(m);
  145.  
  146.   if (rval == TRUE)
  147.     fail;
  148.  
  149.   succeed;
  150. }
  151.  
  152. word
  153. pl_equal(t1, t2)            /* ==/2 */
  154. register Word t1, t2;
  155. { int arity, n;
  156.  
  157.   deRef(t1);
  158.   deRef(t2);
  159.  
  160.   if (isVar(*t1) )
  161.   { if (t1 == t2)
  162.       succeed;
  163.     fail;
  164.   }
  165.  
  166.   if (*t1 == *t2)
  167.     succeed;
  168.  
  169.   if ( isIndirect(*t1) )
  170.   {
  171. #if O_STRING
  172.     if ( isString(*t1) )
  173.     { if ( isString(*t2) && equalString(*t1, *t2) )
  174.         succeed;
  175.       fail;
  176.     }
  177. #endif /* O_STRING */
  178.     if (isReal(*t2) && valReal(*t1) == valReal(*t2) )
  179.       succeed;
  180.     fail;
  181.   }
  182.  
  183.   if (!isTerm(*t1) || !isTerm(*t2) ||
  184.        functorTerm(*t1) != functorTerm(*t2) )
  185.     fail;
  186.  
  187.   arity = functorTerm(*t1)->arity;
  188.   t1 = argTermP(*t1, 0);
  189.   t2 = argTermP(*t2, 0);
  190.   for(n=0; n<arity; n++, t1++, t2++)
  191.     TRY(pl_equal(t1, t2) );
  192.  
  193.   succeed;
  194. }
  195.  
  196. word
  197. pl_nonequal(t1, t2)        /* \== */
  198. Word t1, t2;
  199. { if (pl_equal(t1, t2) == FALSE)
  200.     succeed;
  201.  
  202.   fail;
  203. }
  204.  
  205.  
  206.         /********************************
  207.         *        STANDARD ORDER         *
  208.         *********************************/
  209.  
  210. /*  Rules:
  211.  
  212.     Var < Atom < String < number < Term
  213.     
  214.     OldVar < NewVar    (not relyable)
  215.     Atom:    alphabetically
  216.     Strings:    alphabetically
  217.     number:    value
  218.     Term:    alphabetically / arity / recursive
  219.  
  220.  ** Tue Apr 26 16:25:50 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  221.  
  222. #define LESS -1
  223. #define EQUAL  0
  224. #define GREATER  1
  225.  
  226. #if !O_NO_LEFT_CAST
  227. #define w1 ((word)t1)
  228. #define w2 ((word)t2)
  229. #endif
  230.  
  231. int
  232. compareStandard(t1, t2)
  233. register Word t1, t2;
  234. { int rval;
  235.   int arity;
  236.   int n;
  237.   FunctorDef f1, f2;
  238. #if O_NO_LEFT_CAST
  239.   register word w1, w2;
  240. #endif
  241.  
  242.   deRef(t1);
  243.   deRef(t2);
  244.  
  245.   if (isVar(*t1) )
  246.   { if (isVar(*t2) )
  247.       return t1 < t2 ? LESS : t1 == t2 ? EQUAL : GREATER;
  248.     return LESS;
  249.   }
  250.  
  251.   w2 = *t2;
  252.   if (isVar(w2) )
  253.     return GREATER;
  254.  
  255.   
  256.   w1 = *t1; 
  257.   if (isAtom(w1) )
  258.   { if (isAtom(w2) )
  259.       return strcmp(stringAtom(w1), stringAtom(w2));
  260.     return LESS;
  261.   }
  262.   if (isAtom(w2) )
  263.     return GREATER;
  264.  
  265. #if O_STRING
  266.   if ( isString(w1) )
  267.   { if ( isString(w2) )
  268.       return strcmp(valString(w1), valString(w2));
  269.     return LESS;
  270.   }
  271.   if ( isString(w2) )
  272.     return GREATER;
  273. #endif /* O_STRING */
  274.  
  275.   if ( isNumber(w1) )
  276.   { if ( !isNumber(w2) )
  277.       return LESS;
  278.  
  279.     if ( isInteger(w1) && isInteger(w2) )
  280.     { long i1 = valNum(w1);
  281.       long i2 = valNum(w2);
  282.  
  283.       return i1 < i2 ? LESS : i1 == i2 ? EQUAL : GREATER;
  284.     } else
  285.     { double f1 = (isInteger(w1) ? (double)valNum(w1) : valReal(w1));
  286.       double f2 = (isInteger(w2) ? (double)valNum(w2) : valReal(w2));
  287.     
  288.       return f1 < f2 ? LESS : f1 == f2 ? EQUAL : GREATER;
  289.     }
  290.   }
  291.   if ( isNumber(w2) )
  292.     return GREATER;
  293.   
  294.   SECURE(if (!isTerm(w1) || !isTerm(w2)) sysError("Unknown type"));
  295.  
  296.   f1 = functorTerm(w1);
  297.   f2 = functorTerm(w2);
  298.  
  299.   if ((rval = strcmp(f1->name->name, f2->name->name)) != EQUAL)
  300.     return rval;
  301.   if (f1->arity > f2->arity)
  302.     return GREATER;
  303.   if (f2->arity > f1->arity)
  304.     return LESS;
  305.  
  306.   arity = f1->arity;
  307.   t1 = argTermP(w1, 0);
  308.   t2 = argTermP(w2, 0);
  309.  
  310.   for(n=0; n<arity; n++, t1++, t2++)
  311.   { if ((rval = compareStandard(t1, t2)) != EQUAL)
  312.       return rval;
  313.   }
  314.  
  315.   return EQUAL;
  316. }
  317.  
  318.  
  319. word
  320. pl_compare(rel, t1, t2)
  321. Word rel, t1, t2;
  322. { switch( compareStandard(t1, t2) )
  323.   { case LESS:    return unifyAtomic(rel, ATOM_smaller);
  324.     case EQUAL:    return unifyAtomic(rel, ATOM_equals);
  325.     case GREATER:    
  326.     default:    return unifyAtomic(rel, ATOM_larger);
  327.   }
  328. }
  329.  
  330.  
  331.  
  332. word
  333. pl_lessStandard(t1, t2)        /* @</2 */
  334. Word t1, t2;
  335. { if (compareStandard(t1, t2) < 0)
  336.     succeed;
  337.   fail;
  338. }
  339.  
  340. word
  341. pl_lessEqualStandard(t1, t2)        /* @=</2 */
  342. Word t1, t2;
  343. { if (compareStandard(t1, t2) <= 0)
  344.     succeed;
  345.   fail;
  346. }
  347.  
  348. word
  349. pl_greaterStandard(t1, t2)        /* @>/2 */
  350. Word t1, t2;
  351. { if (compareStandard(t1, t2) > 0)
  352.     succeed;
  353.   fail;
  354. }
  355.  
  356. word
  357. pl_greaterEqualStandard(t1, t2)    /* @>=/2 */
  358. Word t1, t2;
  359. { if (compareStandard(t1, t2) >= 0)
  360.     succeed;
  361.   fail;
  362. }
  363.  
  364.         /********************************
  365.         *     STRUCTURAL EQUIVALENCE    *
  366.         *********************************/
  367. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  368. The  idea  for  this  predicate  is  taken  from  the  usenet   network.
  369. Unfortunately I can't recall the author of the note.
  370.  
  371. Structural equivalency is stronger then unifyable (=), but  weaker  then
  372. pure equivalence (==). Two terms are structural equivalent if their tree
  373. representation is equivalent. Examples:
  374.  
  375.   a =@= A        --> false
  376.   A =@= B        --> true
  377.   foo(A, B) =@= foo(C, D)    --> true
  378.   foo(A, A) =@= foo(B, C)    --> false
  379. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  380.  
  381.  
  382. static int
  383. pl_se(t1, t2, index)
  384. register Word t1, t2;
  385. int index;
  386. { int arity, n;
  387.  
  388.   deRef(t1);
  389.   deRef(t2);
  390.  
  391.   if (isVar(*t1))
  392.   { if (isVar(*t2))
  393.     { unifyFunctor(t1, FUNCTOR_var1);
  394.       unifyFunctor(t2, FUNCTOR_var1);
  395.       unifyAtomic(argTermP(*t1, 0), consNum(index));
  396.       unifyAtomic(argTermP(*t2, 0), consNum(index));
  397.       
  398.       return ++index;
  399.     }
  400.     fail;
  401.   }
  402.  
  403.   if (*t1 == *t2)
  404.     succeed;
  405.  
  406.   if (isIndirect(*t1) )
  407.   { 
  408. #if O_STRING
  409.     if (isString(*t1))
  410.     { if ( isString(*t2) && equalString(*t1, *t2) )
  411.         succeed;
  412.       fail;
  413.     }
  414. #endif /* O_STRING */
  415.     if (isReal(*t2) && valReal(*t1) == valReal(*t2) )
  416.       succeed;
  417.     fail;
  418.   }
  419.  
  420.   if (!isTerm(*t1) || !isTerm(*t2) ||
  421.        functorTerm(*t1) != functorTerm(*t2) )
  422.     fail;
  423.  
  424.   arity = functorTerm(*t1)->arity;
  425.   t1 = argTermP(*t1, 0);
  426.   t2 = argTermP(*t2, 0);
  427.   for(n=0; n<arity; n++, t1++, t2++)
  428.     if ((index = pl_se(t1, t2, index)) == FALSE)
  429.       fail;
  430.  
  431.   return index;
  432. }
  433.  
  434. word
  435. pl_structural_equal(t1, t2)
  436. Word t1, t2;
  437. { mark m;
  438.   bool rval;
  439.  
  440.   Mark(m);
  441.   rval = pl_se(t1, t2, 1);
  442.   Undo(m);
  443.  
  444.   return rval == FALSE ? FALSE : TRUE;
  445. }
  446.  
  447. word
  448. pl_structural_nonequal(t1, t2)
  449. Word t1, t2;
  450. { return pl_structural_equal(t1, t2) == FALSE ? TRUE : FALSE;
  451. }
  452.  
  453.  
  454.         /********************************
  455.         *         TERM HACKING          *
  456.         *********************************/
  457.  
  458. word
  459. pl_functor(t, f, a)
  460. Word t, f, a;
  461. { int arity;
  462.  
  463.   if (isVar(*t) )
  464.   { if (isAtom(*f) && isInteger(*a) )
  465.     { arity = (int) valNum(*a);
  466.       if (arity == 0)
  467.     return unifyAtomic(t, *f);
  468.       if (arity < 0)
  469.         fail;
  470.       return unifyFunctor(t, lookupFunctorDef((Atom)*f, arity));
  471.     }
  472.     fail;
  473.   }
  474.   if (isAtom(*t) )
  475.   { TRY(unifyAtomic(f, *t) );
  476.     return unifyAtomic(a, consNum(0));
  477.   }
  478.   if (!isTerm(*t))
  479.     fail;
  480.  
  481.   TRY(unifyAtomic(f, functorTerm(*t)->name) );
  482.   return unifyAtomic(a, consNum(functorTerm(*t)->arity));
  483. }
  484.  
  485. word
  486. pl_arg(n, term, arg)
  487. register Word n, term, arg;
  488. { int argn;
  489.  
  490.   if (!isInteger(*n))
  491.     return warning("arg/3: first argument in not an integer");
  492.   if (!isTerm(*term))
  493.     return warning("arg/3: second argument in not a term");
  494.   argn = (int) valNum(*n);
  495.   if (argn < 1 || argn > functorTerm(*term)->arity)
  496.     fail;
  497.  
  498.   return pl_unify(argTermP(*term, argn-1), arg);
  499. }
  500.  
  501. /*  Determine the length of a list. If the list is not proper (or not
  502.     a list at all) -1 is returned.
  503.  
  504.  ** Mon Apr 18 16:29:01 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  505.  
  506. int
  507. lengthList(list)
  508. Word list;
  509. { int length = 0;
  510.  
  511.   while(!isNil(*list) )
  512.   { if (!isList(*list) )
  513.       return -1;            /* not a proper list */
  514.     length++;
  515.     list = TailList(list);
  516.     deRef(list);
  517.   }
  518.   if (isNil(*list) )
  519.     return length;
  520.  
  521.   return -1;
  522. }
  523.  
  524. word
  525. pl_univ(t, l)
  526. Word t, l;
  527. { word term;
  528.   int arity, a;
  529.   Word argp;
  530.   int n;
  531.   Word head;
  532.  
  533.   arity = lengthList(l) - 1;
  534.  
  535.   if (isVar(*t) )
  536.   { if (arity < 0)            /* list is not proper */
  537.       fail;
  538.     head = HeadList(l);
  539.     deRef(head);
  540.     if (arity == 0)
  541.     { if ( isAtomic(*head) )
  542.     return unifyAtomic(t, *head);
  543.       fail;
  544.     }
  545.     if (!isAtom(*head) )
  546.       fail;
  547.     term = globalFunctor(lookupFunctorDef((Atom)*head, arity) );
  548.     pl_unify(t, &term);
  549.   } else
  550.   { if (isAtomic(*t) )
  551.     { APPENDLIST(l, t);
  552.       CLOSELIST(l);
  553.       succeed;
  554.     }
  555.     if (!isTerm(*t) )
  556.       fail;
  557.     term = *t;
  558.   }
  559.  
  560.   a = functorTerm(term)->arity;
  561.   if (arity >= 0 && a != arity)
  562.     fail;
  563.  
  564.   APPENDLIST(l, (Word)&(functorTerm(term)->name));
  565.   argp = argTermP(term, 0);
  566.   for(n = 0; n < a; n++, argp++)
  567.   { APPENDLIST(l, argp);
  568.   }
  569.  
  570.   CLOSELIST(l);
  571.  
  572.   succeed;
  573. }
  574.  
  575. int
  576. numberVars(t, functor, n)
  577. register Word t;
  578. FunctorDef functor;
  579. int n;
  580. { Word argp;
  581.   int i, arity;
  582.  
  583.   deRef(t);
  584.   
  585.   if (isVar(*t))
  586.   { unifyFunctor(t, functor);
  587.     unifyAtomic(argTermP(*t, 0), consNum(n));
  588.  
  589.     return ++n;
  590.   }
  591.   if (isTerm(*t))
  592.   { arity = functorTerm(*t)->arity;
  593.     argp = argTermP(*t, 0);
  594.  
  595.     for(i=0; i<arity; i++, argp++)
  596.       n = numberVars(argp, functor, n);
  597.     
  598.     return n;
  599.   }
  600.  
  601.   return n;            /* anything else */
  602. }
  603.  
  604. word
  605. pl_numbervars(t, atom, start, end)
  606. Word t, atom, start, end;
  607. { int n;
  608.   FunctorDef functor;
  609.  
  610.   if (!isInteger(*start) || !isAtom(*atom) )
  611.     fail;
  612.     
  613.   functor = lookupFunctorDef((Atom)*atom, 1);
  614.   n = (int) valNum(*start);
  615.   n = numberVars(t, functor, n);
  616.  
  617.   return unifyAtomic(end, consNum(n));
  618. }
  619.  
  620. static void
  621. resetVariables(t)
  622. register Word t;
  623. { register int arity;
  624.  
  625.   deRef(t);
  626.   if ( !isTerm(*t) )
  627.     return;
  628.   if ( functorTerm(*t) == FUNCTOR_var1 )  
  629.   { setVar(*t);
  630.     return;
  631.   }
  632.   for(arity=functorTerm(*t)->arity, t=argTermP(*t, 0); arity > 0; arity--, t++)
  633.     resetVariables(t);
  634. }
  635.  
  636. static bool
  637. freeVariables(t, l, e)
  638. register Word t, *l;
  639. bool e;
  640. { int arity;
  641.   
  642.   deRef(t);
  643.   if (!isTerm(*t) )
  644.     succeed;
  645.  
  646.   if (e == TRUE && functorTerm(*t) == FUNCTOR_hat2)
  647.   { resetVariables(argTermP(*t, 0));
  648.     return freeVariables(argTermP(*t, 1), l, e);
  649.   }
  650.  
  651.   if (functorTerm(*t) == FUNCTOR_var1)
  652.   { setVar(*t);
  653.     APPENDLIST(*l, t);
  654.     succeed;
  655.   }
  656.   for(arity=functorTerm(*t)->arity, t=argTermP(*t, 0); arity > 0; arity--, t++)
  657.     TRY(freeVariables(t, l, e) );
  658.  
  659.   succeed;
  660. }
  661.  
  662. word
  663. pl_free_variables(t, l)
  664. Word t, l;
  665. { numberVars(t, FUNCTOR_var1, 0);
  666.   
  667.   TRY(freeVariables(t, &l, FALSE) );
  668.   CLOSELIST(l);
  669.  
  670.   succeed;
  671. }
  672.  
  673. word
  674. pl_e_free_variables(t, l)
  675. Word t, l;
  676. { numberVars(t, FUNCTOR_var1, 0);
  677.   
  678.   TRY(freeVariables(t, &l, TRUE) );
  679.   CLOSELIST(l);
  680.  
  681.   succeed;
  682. }
  683.  
  684. static word
  685. copyTerm(f, vars)
  686. Word f;
  687. Table vars;
  688. { deRef(f);
  689.   if ( isVar(*f) )
  690.   { Symbol s = lookupLocalTable(vars, f);
  691.     Word p;
  692.  
  693.     if ( s != (Symbol) NULL )
  694.       return makeRef(s->value);
  695.     p = allocGlobal(sizeof(word));
  696.     setVar(*p);
  697.     addLocalTable(vars, f, p);
  698.  
  699.     return makeRef(p);
  700.   }
  701.   if ( isTerm(*f) )
  702.   { word copy = globalFunctor(functorTerm(*f));
  703.     Word p, q;
  704.     int n;
  705.  
  706.     p = argTermP(copy, 0);
  707.     q = argTermP(*f, 0);
  708.  
  709.     for(n = 0; n < functorTerm(*f)->arity; n++, p++, q++)
  710.       *p = copyTerm(q, vars);
  711.  
  712.     return copy;
  713.   }
  714.  
  715.   return *f;            /* atoms, integers, reals and strings */
  716. }
  717.  
  718.  
  719. word
  720. pl_copy_term(f, t)
  721. Word f, t;
  722. { Table vartable;
  723.   word copy;
  724.  
  725.   initAllocLocal();
  726.   vartable = newLocalTable(16);
  727.   copy = copyTerm(f, vartable);
  728.   stopAllocLocal();
  729.  
  730.   return pl_unify(t, ©);
  731. }
  732.  
  733. bool
  734. unifyStringWithList(s, l)
  735. char *s;
  736. Word l;
  737. { word w;
  738.  
  739.   while(*s)
  740.   { w = consNum((int)*s++);
  741.     APPENDLIST(l, &w);
  742.   }
  743.   CLOSELIST(l);
  744.  
  745.   succeed;
  746. }
  747.  
  748. word
  749. stringToList(s)
  750. char *s;
  751. { word result;
  752.   Word arg;
  753.   FunctorDef dot = FUNCTOR_dot2;
  754.  
  755.   if (*s == EOS)
  756.     return (word)ATOM_nil;
  757.  
  758.   result = globalFunctor(dot);
  759.   arg = argTermP(result, 0);
  760.   *arg++ = consNum((int)*s++);
  761.  
  762.   while(*s)
  763.   { *arg = globalFunctor(dot);
  764.     arg = argTermP(*arg, 0);
  765.     *arg++ = consNum((int)*s++);
  766.   }
  767.  
  768.   *arg = (word)ATOM_nil;
  769.  
  770.   return result;
  771. }
  772.  
  773. char *
  774. listToString(list)
  775. register word list;
  776. { char *result = (char *) lTop;
  777.   char *s = result;
  778.   int c;
  779.   register Word arg;
  780.   Word tail;
  781.  
  782.   while(isList(list) && !isNil(list))
  783.   { arg = argTermP(list, 0);
  784.     deRef(arg);
  785.     if (isInteger(*arg) && (c=(int)valNum(*arg)) > 0 && c < 128)
  786.     { *s++ = (char) c;
  787.       STACKVERIFY( if (s > (char *)lMax) outOf((Stack)&stacks.local) );
  788.       tail = argTermP(list, 1);
  789.       deRef(tail);
  790.       list = *tail;
  791.       continue;
  792.     }
  793.     return (char *)NULL;
  794.   }
  795.   if (!isNil(list))
  796.     return (char *)NULL;
  797.  
  798.   *s = EOS;
  799.  
  800.   return result;
  801. }
  802.  
  803. char *
  804. primitiveToString(w, save)
  805. word w;
  806. bool save;
  807. { static char tmp[25];
  808.  
  809.   if (isAtom(w) )
  810.     return stringAtom(w);
  811.   if (isInteger(w) )
  812.   { sprintf(tmp, "%ld", valNum(w) );
  813.     return save ? store_string_local(tmp) : tmp;
  814.   }
  815.   if (isReal(w) )
  816.   { sprintf(tmp, "%f", valReal(w) );
  817.     return save ? store_string_local(tmp) : tmp;
  818.   }
  819. #if O_STRING
  820.   if (isString(w))
  821.     return valString(w);
  822. #endif /* O_STRING */
  823.  
  824.   return (char *) NULL;
  825. }
  826.  
  827.  
  828. char *
  829. toString(w)
  830. word w;
  831. { char *s;
  832.   if ( (s = primitiveToString(w, FALSE)) != NULL ||
  833.        (s = listToString(w)) != NULL )
  834.     return s;
  835.  
  836.   return NULL;
  837. }
  838.  
  839.  
  840. word
  841. pl_atom_length(w, n)
  842. Word w, n;
  843. { char *s = primitiveToString(*w, FALSE);
  844.   return unifyAtomic(n, consNum(strlen(s)));
  845. }
  846.  
  847. static char *
  848. prependBase(b, s)
  849. int b;
  850. char *s;
  851. { *s-- = '\'';
  852.   while(b > 0)
  853.   { *s-- = digitName(b % 10, TRUE);
  854.     b /= 10;
  855.   }
  856.  
  857.   return s;
  858. }
  859.  
  860. word
  861. pl_int_to_atom(number, base, atom)
  862. Word number, base, atom;
  863. { long n, b;
  864.   char result[100];
  865.   char *s = &result[99];
  866.  
  867.   *s-- = EOS;
  868.   if ( wordToInteger(*number, &n) == FALSE ||
  869.        wordToInteger(*base, &b) == FALSE)
  870.   { warning("int_to_atom/3: instantiation fault");
  871.     fail;
  872.   }
  873.  
  874.   if (b == 0 && n > 0 && n < 128)
  875.   { *s-- = (char) n;
  876.     *s-- = '\'';
  877.     *s = '0';
  878.     return unifyAtomic(atom, lookupAtom(s));
  879.   }
  880.  
  881.   if (b > 36 || b < 2)
  882.     return warning("int_to_atom/3: Illegal base: %d", b);
  883.  
  884.   if (n == 0)
  885.   { *s-- = '0';
  886.     s = prependBase((int)b, s);
  887.     return unifyAtomic(atom, lookupAtom(s+1));
  888.   }
  889.   while(n > 0)
  890.   { *s-- = digitName((int)(n % b), TRUE);
  891.     n /= b;
  892.   }
  893.   if (b != 10)
  894.     s = prependBase((int)b, s);
  895.  
  896.   return unifyAtomic(atom, lookupAtom(s+1));
  897. }
  898.  
  899. /*  format an integer according to  a  number  of  modifiers  at various
  900.     radius.   `split'  is a boolean asking to put ',' between each group
  901.     of three digits (e.g. 67,567,288).  `div' askes to divide the number
  902.     by radix^`div' before printing.   `radix'  is  the  radix  used  for
  903.     conversion.  `n' is the number to be converted.
  904.  
  905.  ** Fri Aug 19 22:26:41 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  906.  
  907. char *
  908. formatInteger(split, div, radix, small, n)
  909. bool split;
  910. int div;
  911. int radix;
  912. bool small;
  913. long n;
  914. { static char tmp[100];
  915.   char *s = tmp + 99;
  916.   int before = (div == 0);
  917.   int digits = 0;
  918.   bool negative = FALSE;
  919.  
  920.   *s = EOS;
  921.   if ( n < 0 )
  922.   { n = -n;
  923.     negative = TRUE;
  924.   }
  925.   if ( n == 0 && div == 0 )
  926.   { *--s = '0';
  927.     return s;
  928.   }
  929.   while( n > 0 || div >= 0 )
  930.   { if ( div-- == 0 && !before )
  931.     { *--s = '.';
  932.       before = 1;
  933.     }
  934.     if ( split && before && (digits++ % 3) == 0 && digits != 1 )
  935.       *--s = ',';
  936.     *--s = digitName((int)(n % radix), small);
  937.     n /= radix;
  938.   }
  939.   if ( negative )
  940.     *--s = '-';  
  941.  
  942.   return s;
  943. }      
  944.  
  945. word
  946. pl_format_number(format, number, string)
  947. Word format, number, string;
  948. { char *fmt;
  949.   int arg;
  950.   char conv;
  951.   word list;
  952.  
  953.   if (!isAtom(*format) )
  954.     return warning("format_number/2: instantiation fault");
  955.   fmt = stringAtom(*format);
  956.   if (*fmt == EOS)
  957.     return warning("format_number/3: illegal format");
  958.   arg = atoi(fmt);
  959.   conv = fmt[strlen(fmt)-1];
  960.  
  961.   switch(conv)
  962.   { case 'D':
  963.     case 'd':
  964.     case 'r':
  965.     case 'R':
  966.       { long i;
  967.  
  968.     if (wordToInteger(*number, &i) == FALSE)
  969.       return warning("format_number/3: 2nd argument is not an integer");
  970.     if (conv == 'd' || conv == 'D')
  971.       list = stringToList(formatInteger(conv == 'D', arg, 10, TRUE, i) );
  972.     else
  973.       list = stringToList(formatInteger(FALSE, 0, arg, conv == 'r', i) );
  974.     return pl_unify(string, &list);
  975.       }
  976.     case 'e':
  977.     case 'E':
  978.     case 'f':
  979.     case 'g':
  980.     case 'G':
  981.       { real f;
  982.     char tmp[100];
  983.     char form2[10];
  984.  
  985.     if (fmt[1] == EOS)
  986.       arg = 6;
  987.     if (wordToReal(*number, &f) == FALSE)
  988.       return warning("format_number/3: 2nd argument is not a float");
  989.     sprintf(form2, "%%.%d%c", arg, conv);
  990.     sprintf(tmp, form2, f);
  991.     list = stringToList(tmp);
  992.     return pl_unify(string, &list);
  993.       }
  994.     default:
  995.       return warning("format_number/3: illegal conversion code");
  996.   }
  997. }
  998.  
  999. static bool
  1000. isPrefix(s, q)
  1001. register char *s, *q;
  1002. { while(*s && *s == *q)
  1003.     s++, q++;
  1004.  
  1005.   return *s == EOS;
  1006. }
  1007.  
  1008. word
  1009. pl_name(atom, string)
  1010. Word atom, string;
  1011. { register char *s;
  1012.  
  1013.   if ((s = primitiveToString(*atom, FALSE)) != (char *)NULL)
  1014.     return unifyStringWithList(s, string);
  1015.  
  1016.   if (isVar(*atom) )
  1017.   { register char *q;
  1018.     int n;
  1019.  
  1020.     if ((s = listToString(*string)) == (char *)NULL)
  1021.       return warning("name/2: 2nd argument is not a string");
  1022.     if ( isDigit(*s) )
  1023.     { for(q=s; *q && isDigit(*q); q++) ;
  1024.       if (*q == EOS)
  1025.       { n = atoi(s);
  1026.     return unifyAtomic(atom, consNum(n));
  1027.       }
  1028.     }
  1029.     return unifyAtomic(atom, lookupAtom(s) );
  1030.   }
  1031.  
  1032.   return warning("name/2: instantiation fault");
  1033. }
  1034.  
  1035. word
  1036. pl_concat(a1, a2, a3)
  1037. Word a1, a2, a3;
  1038. { char *s1, *s2, *s3;
  1039.   long l1, l2, l3;
  1040.   char *tmp;
  1041.  
  1042.   initAllocLocal();
  1043.  
  1044.   s1 = primitiveToString(*a1, TRUE);
  1045.   s2 = primitiveToString(*a2, TRUE);
  1046.   s3 = primitiveToString(*a3, TRUE);
  1047.  
  1048.   if (s1 && s2)
  1049.   { l1 = strlen(s1);
  1050.     tmp = (char *)allocLocal(l1 + strlen(s2));
  1051.     strcpy(tmp, s1);
  1052.     strcpy(tmp+l1, s2);
  1053.     stopAllocLocal();
  1054.     return unifyAtomic(a3, lookupAtom(tmp));
  1055.   }
  1056.  
  1057.   stopAllocLocal();
  1058.  
  1059.   if (!s3)
  1060.     return warning("concat/3: instantiation fault");
  1061.  
  1062.   if (s1)
  1063.   { if (isPrefix(s1, s3) )
  1064.       return unifyAtomic(a2, lookupAtom(s3+strlen(s1)) );
  1065.     fail;
  1066.   }
  1067.  
  1068.   if (s2)
  1069.   { char end;
  1070.     int rval;
  1071.  
  1072.     l2 = strlen(s2);
  1073.     l3 = strlen(s3);
  1074.     if (l2 > l3 || !streq(s3+l3-l2, s2) )
  1075.       fail;
  1076.     end = s3[l3-l2], s3[l3-l2] = EOS;
  1077.     rval = unifyAtomic(a1, lookupAtom(s3));
  1078.     s3[l3-l2] = end;
  1079.     
  1080.     return rval;
  1081.   }
  1082.  
  1083.   return warning("concat/3: instantiation fault");
  1084. }
  1085.  
  1086. word
  1087. pl_concat_atom(list, atom)
  1088. Word list, atom;
  1089. { char *tmp = (char *) lTop;
  1090.   char *base = tmp;
  1091.   Word arg;
  1092.   char *s;
  1093.   long l;
  1094.  
  1095.   *tmp = EOS;
  1096.   while(!isNil(*list) )
  1097.   { if (!isList(*list) )
  1098.       return warning("concat_atom/2: instantiation fault");
  1099.     arg = HeadList(list);
  1100.     deRef(arg);
  1101.     if ((s = primitiveToString(*arg, FALSE)) == (char *) NULL)
  1102.       return warning("concat_atom/2: instantiation fault");
  1103.     l = strlen(s);
  1104.     STACKVERIFY( if (tmp + l > (char *) lMax) outOf((Stack)&stacks.local) );
  1105.     strcpy(tmp, s);
  1106.     tmp += l;
  1107.     list = TailList(list);
  1108.   }
  1109.   
  1110.   return unifyAtomic(atom, lookupAtom(base) );
  1111. }
  1112.  
  1113. word
  1114. pl_apropos_match(a1, a2)
  1115. Word a1, a2;
  1116. { char *s1, *s2, *q, *s;
  1117.  
  1118.   initAllocLocal();
  1119.   s1 = primitiveToString(*a1, TRUE);
  1120.   s2 = primitiveToString(*a2, TRUE);
  1121.   stopAllocLocal();
  1122.   if ( s1 == NULL || s2 == NULL )
  1123.     return warning("$apropos_match/2: instantiation fault");
  1124.  
  1125.   for (; *s2; s2++)
  1126.   { for(q=s1, s=s2; *q && *s; q++, s++)
  1127.     { if ( *q != *s && *q != toLower(*s) )
  1128.         break;
  1129.     }
  1130.     if ( *q == EOS )
  1131.       succeed;
  1132.   }
  1133.  
  1134.   fail;
  1135. }
  1136.  
  1137. #if O_STRING
  1138. /* - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
  1139. Provisional String manipulation functions.
  1140. - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - */
  1141.  
  1142. word
  1143. pl_string_length(str, l)
  1144. Word str, l;
  1145. { char *s;
  1146.  
  1147.   if ( isString(*str) )
  1148.     return unifyAtomic(l, consNum(sizeString(*str)));
  1149.  
  1150.   if ( (s=primitiveToString(*str, FALSE)) == NULL )
  1151.     return warning("string_length/2: instantiation fault");
  1152.  
  1153.   return unifyAtomic(l, consNum(strlen(s)));
  1154. }
  1155.  
  1156. word
  1157. pl_string_to_atom(str, a)
  1158. Word str, a;
  1159. { char *s;
  1160.  
  1161.   if ( (s = primitiveToString(*str, FALSE)) != (char *) NULL )
  1162.     return unifyAtomic(a, lookupAtom(s));
  1163.   if ( (s = primitiveToString(*a, FALSE)) != (char *) NULL )
  1164.     return unifyAtomic(str, globalString(s));
  1165.  
  1166.   return warning("string_to_atom/2: instantiation fault");
  1167. }
  1168.  
  1169. word
  1170. pl_string_to_list(str, list)
  1171. Word str, list;
  1172. { char *s;
  1173.  
  1174.   if ( (s = primitiveToString(*str, FALSE)) != (char *) NULL )
  1175.     return unifyStringWithList(s, list);
  1176.  
  1177.   if ( (s = listToString(*list)) != (char *) NULL )
  1178.     return unifyAtomic(str, globalString(s));
  1179.  
  1180.   return warning("string_to_list/2 instantiation fault");
  1181. }
  1182.  
  1183. word
  1184. pl_substring(str, offset, length, sub)
  1185. Word str, offset, length, sub;
  1186. { long off, l, size, end;
  1187.   char *s, c;
  1188.   word ss;
  1189.  
  1190.   if ( !isString(*str) || !isInteger(*offset) || !isInteger(*length) )
  1191.     return warning("substring/4: instantiation fault");
  1192.  
  1193.   size = sizeString(*str);
  1194.   off = valNum(*offset);
  1195.   l = valNum(*length);
  1196.   end = off + l - 1;
  1197.   if ( off < 1 || off > size || l < 0 || end > size )
  1198.     return warning("substring/4: index out of range");
  1199.  
  1200.   s = valString(*str);
  1201.   c = s[end];
  1202.   s[end] = EOS;
  1203.  
  1204.   if ( isString(*sub) )
  1205.   { if ( streq(&s[off-1], valString(*sub)) )
  1206.     { s[end] = c;
  1207.       succeed;
  1208.     }
  1209.     s[end] = c;
  1210.     fail;
  1211.   }
  1212.   if ( !isVar(*sub) )
  1213.   { s[end] = c;
  1214.     fail;
  1215.   }
  1216.  
  1217.   ss = globalString(&s[off-1]);
  1218.   s[end] = c;
  1219.  
  1220.   return unifyAtomic(sub, ss);
  1221. }
  1222. #endif /* O_STRING */
  1223.  
  1224. word
  1225. pl_write_on_atom(goal, atom)
  1226. Word goal, atom;
  1227. { char string[10240];
  1228.   bool rval;
  1229.  
  1230.   tellString(string, 10240);
  1231.   rval = callGoal(MODULE_user, *goal, FALSE);
  1232.   toldString();
  1233.   TRY(rval);
  1234.   return unifyAtomic(atom, lookupAtom(string) );
  1235. } 
  1236.  
  1237. #if O_STRING
  1238. word
  1239. pl_write_on_string(goal, string)
  1240. Word goal, string;
  1241. { char tmp[10240];
  1242.   bool rval;
  1243.  
  1244.   tellString(tmp, 10240);
  1245.   rval = callGoal(MODULE_user, *goal, FALSE);
  1246.   toldString();
  1247.   TRY(rval);
  1248.   return unifyAtomic(string, globalString(tmp));
  1249. } 
  1250. #endif /* O_STRING */
  1251.  
  1252. word
  1253. pl_write_on_list(goal, string)
  1254. Word goal, string;
  1255. { char tmp[10240];
  1256.   word list;
  1257.   bool rval;
  1258.  
  1259.   tellString(tmp, 10240);
  1260.   rval = callGoal(MODULE_user, *goal, FALSE);
  1261.   toldString();
  1262.   TRY(rval);
  1263.   list = stringToList(tmp);
  1264.   return pl_unify(string, &list);
  1265. } 
  1266.  
  1267. word
  1268. pl_term_to_atom(term, atom, bindings)
  1269. Word term, atom, bindings;
  1270. { char *s;
  1271.  
  1272.   if ( isVar(*atom) )
  1273.   { word rval;
  1274.     
  1275.     s = (char *) lTop;
  1276. #if O_DYNAMIC_STACKS
  1277.     tellString(s, 10000000L);
  1278. #else
  1279.     tellString(s, (char *)lMax - (char *)lTop);
  1280. #endif
  1281.     rval = pl_writeq(term);
  1282.     toldString();
  1283.     TRY(rval);
  1284.     return unifyAtomic(atom, lookupAtom(s) );
  1285.   }
  1286.  
  1287.   if ( (s = primitiveToString(*atom, FALSE)) != (char *)NULL )
  1288.   { word rval;
  1289.  
  1290.     seeString(s);
  1291.     if ( isVar(*bindings) )
  1292.       rval = pl_read_variables(term, bindings);
  1293.     else
  1294.       rval = pl_read(term);
  1295.     seenString();
  1296.     return rval;
  1297.   }
  1298.  
  1299.   return warning("term_to_atom/2: instantiation fault");
  1300. }
  1301.  
  1302.         /********************************
  1303.         *            CONTROL            *
  1304.         *********************************/
  1305.  
  1306. word
  1307. pl_repeat(h)
  1308. word h;
  1309. { switch( ForeignControl(h) )
  1310.   { case FRG_FIRST_CALL:
  1311.     case FRG_REDO:
  1312.       ForeignRedo(2L);
  1313.     case FRG_CUTTED:
  1314.     default:
  1315.       succeed;
  1316.   }
  1317. }
  1318.  
  1319. word
  1320. pl_fail()        /* just to define it */
  1321. { fail;
  1322. }
  1323.  
  1324. word
  1325. pl_halt()
  1326. { Halt(0);
  1327.   /*NOTREACHED*/
  1328.   fail;
  1329. }
  1330.  
  1331.         /********************************
  1332.         *          STATISTICS           *
  1333.         *********************************/
  1334.  
  1335. /*  Return various runtime statistics.
  1336.  
  1337.  ** Sun Apr 17 15:38:46 1988  jan@swivax.UUCP (Jan Wielemaker)  */
  1338.  
  1339. #define makeNum(n)    ((n) < PLMAXINT ? consNum(n) : globalReal((real)n))
  1340.  
  1341. word
  1342. pl_statistics(k, value)
  1343. Word k, value;
  1344. { word result;
  1345.   Atom key;
  1346.  
  1347.   if (!isAtom(*k) )
  1348.     return warning("statistics/2: instantiation fault");
  1349.   key = (Atom) *k;
  1350.  
  1351.   if      (key == ATOM_cputime)                /* time */
  1352.     result = globalReal(CpuTime());
  1353.   else if (key == ATOM_inferences)            /* inferences */
  1354.     result = makeNum(statistics.inferences);
  1355.   else if (key == ATOM_local)                /* local stack */
  1356.     result = makeNum((long)lMax - (long)lBase);
  1357.   else if (key == ATOM_localused)
  1358.     result = makeNum((long)lTop - (long)lBase);
  1359.   else if (key == ATOM_locallimit)
  1360.     result = makeNum(stacks.local.limit);
  1361.   else if (key == ATOM_heapused)            /* heap */
  1362.     result = makeNum(statistics.heap);
  1363.   else if (key == ATOM_trail)                /* trail */
  1364.     result = makeNum((long)tMax - (long)tBase);
  1365.   else if (key == ATOM_trailused)
  1366.     result = makeNum((long)tTop - (long)tBase);
  1367.   else if (key == ATOM_traillimit)
  1368.     result = makeNum(stacks.trail.limit);
  1369.   else if (key == ATOM_global)                /* global */
  1370.     result = makeNum((long)gMax - (long)gBase);
  1371.   else if (key == ATOM_globalused)
  1372.     result = makeNum((long)gTop - (long)gBase);
  1373.   else if (key == ATOM_globallimit)
  1374.     result = makeNum(stacks.global.limit);
  1375.   else if (key == ATOM_atoms)                /* atoms */
  1376.     result = consNum(statistics.atoms);
  1377.   else if (key == ATOM_functors)            /* functors */
  1378.     result = consNum(statistics.functors);
  1379.   else if (key == ATOM_predicates)            /* predicates */
  1380.     result = consNum(statistics.predicates);
  1381.   else if (key == ATOM_modules)                /* modules */
  1382.     result = consNum(statistics.modules);
  1383.   else if (key == ATOM_externals)            /* externals */
  1384.     result = consNum(statistics.externals);
  1385.   else if (key == ATOM_codes)                /* codes */
  1386.     result = consNum(statistics.codes);
  1387.   else if (key == ATOM_gctime)
  1388.     result = globalReal(gc_status.time);
  1389.   else if (key == ATOM_collections)
  1390.     result = consNum(gc_status.collections);
  1391.   else if (key == ATOM_collected)
  1392.     result = makeNum(gc_status.trail_gained + gc_status.global_gained);
  1393.   else if (key == ATOM_core_left)            /* core left */
  1394. #if tos
  1395.     result = consNum((long)coreleft());
  1396. #else
  1397.     fail;
  1398. #endif
  1399.   else
  1400.     return warning("statistics/2: unknown key");
  1401.  
  1402.   return unifyAtomic(value, result);
  1403. }
  1404.  
  1405.         /********************************
  1406.         *            VERSION            *
  1407.         *********************************/
  1408.  
  1409. word
  1410. pl_version(v)
  1411. Word v;
  1412. { return unifyAtomic(v, lookupAtom(systemDefaults.version));
  1413. }
  1414.  
  1415. word
  1416. pl_arch(m, os)
  1417. Word m, os;
  1418. { TRY(   unifyAtomic(m,  lookupAtom(systemDefaults.machine)) );
  1419.   return unifyAtomic(os, lookupAtom(systemDefaults.operating_system));
  1420. }
  1421.  
  1422. word
  1423. pl_home(h)
  1424. Word h;
  1425. { return unifyAtomic(h, lookupAtom(systemDefaults.home));
  1426. }
  1427.  
  1428.  
  1429.         /********************************
  1430.         *            OPTIONS            *
  1431.         *********************************/
  1432.  
  1433. /*   Obtain those options we need in the Prolog code from the option
  1434.      structure.
  1435. */
  1436.  
  1437. word
  1438. pl_option(key, value)
  1439. Word key, value;
  1440. { Atom result;
  1441.   Atom k;
  1442.  
  1443.   if (!isAtom(*key))
  1444.     fail;
  1445.   k = (Atom) *key;
  1446.  
  1447.   if (     k == ATOM_goal)    result = lookupAtom(options.goal);
  1448.   else if (k == ATOM_top_level) result = lookupAtom(options.topLevel);
  1449.   else if (k == ATOM_init_file) result = lookupAtom(options.initFile);
  1450.   else fail;
  1451.  
  1452.   return unifyAtomic(value, result);
  1453. }
  1454.  
  1455. static bool
  1456. boolPlease(b, old, new)
  1457. bool *b;
  1458. register Word old, new;
  1459. { Atom a;
  1460.  
  1461.   TRY( unifyAtomic(old, *b ? ATOM_on : ATOM_off) );
  1462.   a = (Atom) *new;
  1463.  
  1464.   if      ( a == ATOM_on )    *b = TRUE;
  1465.   else if ( a == ATOM_off )    *b = FALSE;
  1466.   else return warning("please/3: 3rd must be `on' or `off'");
  1467.  
  1468.   succeed;
  1469. }
  1470.  
  1471. word
  1472. pl_please(key, old, new)
  1473. Word key, old, new;
  1474. { Atom k;
  1475.  
  1476.   if ( !isAtom(*key) )
  1477.     fail;
  1478.   k = (Atom) *key;
  1479.  
  1480.   if   ( k == ATOM_optimise )
  1481.     return boolPlease(&status.optimise, old, new);
  1482.   else
  1483.     return warning("please/3: unknown key: %s", stringAtom(*key));
  1484. }
  1485.  
  1486.         /********************************
  1487.         *         STYLE CHECK           *
  1488.         *********************************/
  1489.  
  1490. word
  1491. pl_style_check(old, new)
  1492. Word old, new;
  1493. { TRY(unifyAtomic(old, consNum(debugstatus.styleCheck)) );
  1494.   if (!isInteger(*new) )
  1495.     fail;
  1496.   debugstatus.styleCheck = (int) valNum(*new);
  1497.   systemMode(debugstatus.styleCheck & DOLLAR_STYLE);
  1498.  
  1499.   succeed;
  1500. }
  1501.  
  1502.         /********************************
  1503.         *        USER MODELLING?        *
  1504.         *********************************/
  1505.  
  1506. word
  1507. pl_novice(old, new)
  1508. Word old, new;
  1509. { TRY(unifyAtomic(old, novice == TRUE ? ATOM_on : ATOM_off) );
  1510.  
  1511.   if (!isAtom(*new))
  1512.     fail;
  1513.   if (*new == (word) ATOM_on)
  1514.     novice = TRUE;
  1515.   else if (*new == (word) ATOM_off)
  1516.     novice = FALSE;
  1517.   else
  1518.     fail;
  1519.  
  1520.   succeed;
  1521. }
  1522.