home *** CD-ROM | disk | FTP | other *** search
/ Vectronix 2 / VECTRONIX2.iso / FILES_01 / X_PROLOG.LZH / X_PROLOG / SOURCES / BISYS.C < prev    next >
C/C++ Source or Header  |  1990-08-13  |  7KB  |  331 lines
  1. /*
  2.  *        X PROLOG  Vers. 2.0
  3.  *
  4.  *
  5.  *    Written by :     Andreas Toenne
  6.  *            CS Dept. , IRB
  7.  *            University of Dortmund, W-Germany
  8.  *            <at@unido.uucp>
  9.  *            <....!seismo!unido!at>
  10.  *            <at@unido.bitnet>
  11.  *
  12.  *    Copyright :    This software is copyrighted by Andreas Toenne.
  13.  *            Permission is granted hereby to copy the entire
  14.  *            package including this copyright notice without fee.
  15.  *
  16.  */
  17.  
  18. #include "prolog.h"
  19. #include "error.h"
  20. #include "extern.h"
  21. #ifdef ATARI
  22. #include <osbind.h>
  23. #endif
  24. #ifdef VAX
  25. #include <sys/types.h>
  26. #include <sys/times.h>
  27. #endif
  28.  
  29. extern term *term_copy();            /* terms */
  30. extern functor *get_functor();            /* functor */
  31. extern term *argument();            /* terms */
  32. extern void bind_2_vars();            /* terms */
  33. extern term *int_copy();            /* terms */
  34. extern term *var_copy();            /* terms */
  35.  
  36. short bihalt(/* args */)
  37. /* term *args[]; */
  38. {
  39.     puts("X Prolog halted.");
  40.     exit(0);
  41. }
  42.  
  43. short bish(/* args */)
  44. /* term *args[]; */
  45. {
  46.     if (system("msh") != 0)
  47.         return(FALSE);
  48.     else
  49.         return(TRUE);
  50. }
  51.  
  52. /*    SYSTEM ( term ) */
  53.  
  54. short bisystem(args)
  55. term *args[];
  56. {
  57.     if (! ISATOM(args[0]))
  58.         BIERROR(EBAD);
  59.         
  60.     if (system(NAME(args[0])) != 0)
  61.         return(FALSE);
  62.     else
  63.         return(TRUE);
  64. }
  65.  
  66. /*    STATISTICS */
  67.  
  68. short bistatistics(/* args */)
  69. /* term *args; */
  70. {
  71.     term *t;
  72.     register char *c;
  73.     long i;
  74.     
  75.     printf("\n\t\t\t********* X Prolog Statistics *********\n\n");
  76.     printf("Prototype Space:\t%ld bytes free of %ld bytes\n",
  77.         (long)protofull-(long)protonext, (long)protofull-(long)protostack);
  78.     for (t=(term *)copyfull; t>=(term *)copystack && !t->flags; t--);
  79.     printf("Copystack:\t\t%ld bytes free of %ld bytes (min %ld)\n",
  80.         (long)copyfull-(long)copynext,(long)copyfull-(long)copystack,
  81.         (long)copyfull-(long)t);
  82.     printf("Clause Space:\t\t%ld clauses free of %ld\n",
  83.         clausefull-(long)(clausenext-clausesp), clausefull);
  84.     printf("Functor Space:\t\t%ld bytes free of %ld\n",
  85.         (long)functorfull-(long)functornext, 
  86.         (long)functorfull-(long)functorsp);
  87.     for (c=stackfull; c>stacktop && !*c; c--, c--, c--);
  88.     printf("Local Stack:\t\t%ld bytes free of %ld (min %ld)\n",
  89.         (long)stackfull-(long)stacktop, (long)stackfull-(long)stack,
  90.         (long)stackfull-(long)c);
  91.     for (i=trailfull-1; i>=0 && !trailstack[i]; i--);
  92.     printf("Trail Stack:\t\t%ld trails free of %ld (min %ld)\n",
  93.         trailfull-trailtop, trailfull, trailfull-i);
  94.     return(TRUE);
  95. }
  96.  
  97. /*    PROMPT ( old, new )    */
  98.  
  99. short biprompt(args)
  100. term *args[];
  101. {
  102.     short res = TRUE;
  103.  
  104.     if (!ISATOM(args[1]) &&
  105.         (args[0] != args[1]))
  106.         BIERROR(EBAD);
  107.             
  108.     if (ISVAR(args[0]))
  109.     {
  110.         BIND_VAR(args[0], prompt);
  111.     }
  112.     else
  113.         res = (FUNC(args[0]) == FUNC(prompt));
  114.     if (res)
  115.         prompt = args[1];
  116.     return(res);
  117. }
  118.  
  119. /*    $PROMPT( prompt )    */
  120. /*    Neccessary to reset lastc after our last get */
  121.  
  122. short bidollarprompt(args)
  123. term *args[];
  124. {
  125.     if (!ISATOM(args[0]))
  126.         BIERROR(EBAD);
  127.  
  128.     lastc = ' ';        
  129.     if (FUNC(in->atom) != USERFUNCTOR)
  130.         return(TRUE);
  131.         
  132.     fprintf(stdout, "%s", NAME(args[0]));
  133.     return(TRUE);
  134. }
  135.  
  136. /*    DEBUG    */
  137.  
  138. short bidebug( /* args */ )
  139. /* term *args[]; */
  140. {
  141.     dodebug = TRUE;
  142.     return(TRUE);
  143. }
  144.  
  145. /*    NODEBUG  */
  146.  
  147. short binodebug( /* args */ )
  148. /* term *args[]; */
  149. {
  150.     dodebug = FALSE;
  151.     return(TRUE);
  152. }
  153.  
  154. /*    $goalvars ( var )    */
  155.  
  156. short bidollargoalvars(args)
  157. term *args[];
  158. {
  159.     register term *t,*p;
  160.     register short i=0;
  161.     
  162.     if (!ISVAR(args[0]))
  163.         BIERROR(EBAD);
  164.         
  165.     if (!tide)                /* no vars read */
  166.     {
  167.         BIND_VAR(args[0], NILATOM);
  168.         return(TRUE);
  169.     }
  170.     
  171.     p = term_copy(DOTFUNCTOR);
  172.     t = p;
  173.     
  174.     do
  175.     {
  176.         ARG(t,1) = term_copy(COMMAFUNCTOR);
  177.         ARG(ARG(t,1),1) = term_copy(get_functor(l_table[i].name,0));
  178.         ARG(ARG(t,1),2) = l_table[i].t;
  179.         i++;
  180.         if (i<tide)
  181.         {
  182.             ARG(t,2) = term_copy(DOTFUNCTOR);
  183.             t = ARG(t,2);
  184.         }
  185.     } while (i < tide);
  186.     ARG(t,2) = NILATOM;
  187.     BIND_VAR(args[0], p);
  188.     return(TRUE);
  189. }
  190.  
  191. /*    $more */
  192.  
  193. short bidollarmore(args)
  194. term *args[];
  195. {
  196.     term *t;
  197.     
  198.     if (!ISVAR(args[0]))
  199.         BIERROR(EBAD);
  200.  
  201.     if (Backpoint->frozen_env > Topenv->pre)
  202.         t = term_copy(get_functor("yes",0));
  203.     else
  204.         t = term_copy(get_functor("no",0));
  205.                 
  206.     BIND_VAR(args[0], t);
  207.     return(TRUE);
  208. }
  209.  
  210. /*    CPUTIME    */
  211. /*    Primitive for bimath. Returns count of milliseconds since start of */
  212. /*    Prolog. */
  213. /*    Note! Atari dependent */
  214.  
  215. #ifdef ATARI
  216.  
  217. long    current_tic()            /* return value of $4BA    */
  218. {
  219.     return(*(long *)0x4ba);
  220. }
  221.  
  222. void    init_cputime()            /* for the very first time */
  223. {
  224.     s_time = Supexec(current_tic);
  225. }
  226.  
  227. long cputime()
  228. {
  229.     return((Supexec(current_tic)-s_time)*5); /* 200 Hz tic */
  230. }
  231.  
  232. #endif ATARI
  233.  
  234. #ifdef VAX
  235.  
  236. struct tms tb;
  237.  
  238. void    init_cputime()
  239. {
  240. }
  241.  
  242. long cputime()
  243. {
  244.     times(&tb);
  245.  
  246.     return(tb.tms_utime * 16);
  247. }
  248.  
  249. #endif
  250.  
  251. /*    HIDE ( list of predicates )    */
  252.  
  253. short bihide(args)
  254. term *args[];
  255. {
  256.     register term *t = args[0];
  257.     
  258.     if (!ISSTRUCT(t) || FUNC(t) != DOTFUNCTOR)
  259.         BIERROR(EBAD);
  260.         
  261.     while (FUNC(t) == DOTFUNCTOR)
  262.     {
  263.         if (!ISSTRUCT(argument(t, Topenv, 1)))
  264.             return(FALSE);
  265.         FUNC(argument(t, Topenv, 1))->flags |= HIDDEN;
  266.         t = argument(t, Topenv, 2);
  267.     }
  268.     return(TRUE);
  269. }
  270.  
  271. /*    PROTECT ( list of predicates )    */
  272.  
  273. short biprotect(args)
  274. term *args[];
  275. {
  276.     register term *t = args[0];
  277.     
  278.     if (!ISSTRUCT(t) || FUNC(t) != DOTFUNCTOR)
  279.         BIERROR(EBAD);
  280.         
  281.     while (FUNC(t) == DOTFUNCTOR)
  282.     {
  283.         if (!ISSTRUCT(argument(t, Topenv, 1)))
  284.             return(FALSE);
  285.         FUNC(argument(t, Topenv, 1))->flags |= PROTECTED;
  286.         t = argument(t, Topenv, 2);
  287.     }
  288.     return(TRUE);
  289. }
  290.  
  291. /*    REVEAL ( list of predicates )    */
  292.  
  293. short bireveal(args)
  294. term *args[];
  295. {
  296.     register term *t = args[0];
  297.     
  298.     if (!ISSTRUCT(t) || FUNC(t) != DOTFUNCTOR)
  299.         BIERROR(EBAD);
  300.         
  301.     while (FUNC(t) == DOTFUNCTOR)
  302.     {
  303.         if (!ISSTRUCT(argument(t, Topenv, 1)))
  304.             return(FALSE);
  305.         FUNC(argument(t, Topenv, 1))->flags &= ~HIDDEN;
  306.         t = argument(t, Topenv, 2);
  307.     }
  308.     return(TRUE);
  309. }
  310.  
  311. /*    UNPROTECT ( list of predicates )    */
  312.  
  313. short biunprotect(args)
  314. term *args[];
  315. {
  316.     register term *t = args[0];
  317.     
  318.     if (!ISSTRUCT(t) || FUNC(t) != DOTFUNCTOR)
  319.         BIERROR(EBAD);
  320.         
  321.     while (FUNC(t) == DOTFUNCTOR)
  322.     {
  323.         if (!ISSTRUCT(argument(t, Topenv, 1)))
  324.             return(FALSE);
  325.         FUNC(argument(t, Topenv, 1))->flags &= ~PROTECTED;
  326.         t = argument(t, Topenv, 2);
  327.     }
  328.     return(TRUE);
  329. }
  330.  
  331.