home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / lifeos2.zip / LIFE-1.02 / SOURCE / BI_SYS.C < prev    next >
C/C++ Source or Header  |  1996-06-15  |  15KB  |  691 lines
  1. /* Copyright 1992 Digital Equipment Corporation
  2.    All Rights Reserved
  3. */
  4. /*     $Id: bi_sys.c,v 1.2 1994/12/08 23:08:17 duchier Exp $     */
  5.  
  6. #ifndef lint
  7. static char vcid[] = "$Id: bi_sys.c,v 1.2 1994/12/08 23:08:17 duchier Exp $";
  8. #endif /* lint */
  9.  
  10. #include "extern.h"
  11. #include "trees.h"
  12. #include "login.h"
  13. #include "parser.h"
  14. #include "copy.h"
  15. #include "token.h"
  16. #include "print.h"
  17. #include "lefun.h"
  18. #include "memory.h"
  19. #include "modules.h"
  20. #ifndef OS2_PORT
  21. #include "built_ins.h"
  22. #else
  23. #include "error.h"
  24. ptr_psi_term makePsiTerm(ptr_definition x);
  25. #endif
  26.  
  27. #define copyPsiTerm(a,b)        (ptr_psi_term )memcpy(a,b,sizeof(psi_term))
  28.  
  29. /******** C_TRACE
  30.   With no arguments: Toggle the trace flag & print a message saying whether
  31.   tracing is on or off.
  32.   With argument 1: If it is top, return the trace flag and disable tracing.
  33.   If it is true or false, set the trace flag to that value.  Otherwise, give
  34.   an error.
  35.   With argument 2: If it is top, return the stepflag and disable stepping.
  36.   If it is true or false, set the stepflag to that value.  Otherwise, give
  37.   an error.
  38. */
  39. long c_trace()
  40. {
  41.   long success=TRUE;
  42.   ptr_psi_term t,arg1,arg2;
  43.  
  44.   t=aim->a;
  45.   deref_args(t,set_empty);
  46.   get_two_args(t->attr_list,&arg1,&arg2);
  47.   if (arg1) {
  48.     deref_ptr(arg1);
  49.     if (is_top(arg1)) {
  50.       unify_bool_result(arg1,trace);
  51.       trace=FALSE;
  52.     }
  53.     else if (arg1->type==true)
  54.       trace=TRUE;
  55.     else if (arg1->type==false)
  56.       trace=FALSE;
  57.     else {
  58.       Errorline("bad first argument in %P.\n",t);
  59.       /* report_error(t,"bad first argument"); */
  60.       success=FALSE;
  61.     }
  62.   }
  63.   if (arg2) {
  64.     deref_ptr(arg2);
  65.     if (is_top(arg2)) {
  66.       unify_bool_result(arg2,stepflag);
  67.       stepflag=FALSE;
  68.     }
  69.     else if (arg2->type==true)
  70.       stepflag=TRUE;
  71.     else if (arg2->type==false)
  72.       stepflag=FALSE;
  73.     else {
  74.       Errorline("bad second argument in %P.\n",t);
  75.       /* report_error(t,"bad second argument"); */
  76.       success=FALSE;
  77.     }
  78.   }
  79.   if (!arg1 && !arg2)
  80.     toggle_trace();
  81.   return success;
  82. }
  83.  
  84. long c_tprove()
  85. {
  86.   ptr_psi_term t;
  87.  
  88.   t=aim->a;
  89.   deref_args(t,set_empty);
  90.   set_trace_to_prove();
  91.   return TRUE;
  92. }
  93.  
  94. /******** C_STEP
  95.   Toggle the single step flag & print a message saying whether
  96.   single stepping mode is on or off.
  97. */
  98. static long c_step()
  99. {
  100.   ptr_psi_term t;
  101.  
  102.   t=aim->a;
  103.   deref_args(t,set_empty);
  104.   toggle_step();
  105.   return TRUE;
  106. }
  107.  
  108. /******** C_VERBOSE
  109.   Toggle the verbose flag & print a message saying whether
  110.   verbose mode is on or off.
  111. */
  112. static long c_verbose()
  113. {
  114.   ptr_psi_term t;
  115.  
  116.   t=aim->a;
  117.   deref_args(t,set_empty);
  118.   verbose = !verbose;
  119.   printf("*** Verbose mode is turned ");
  120.   printf(verbose?"on.\n":"off.\n");
  121.   return TRUE;
  122. }
  123.  
  124. /******** C_WARNING
  125.   Toggle the warning flag & print a message saying whether
  126.   warnings are printed or not.
  127.   Default: print warnings.
  128.   (Errors cannot be turned off.)
  129. */
  130. static long c_warning()
  131. {
  132.   ptr_psi_term t;
  133.  
  134.   t=aim->a;
  135.   deref_args(t,set_empty);
  136.   warningflag = !warningflag;
  137.  
  138.   /*  RM: Sep 24 1993  */
  139.   Infoline("*** Warning messages are%s printed\n",warningflag?"":" not");
  140.   
  141.   return TRUE;
  142. }
  143.  
  144. /******** C_MAXINT
  145.   Return the integer of greatest magnitude that guarantees exact
  146.   integer arithmetic.
  147. */
  148. static long c_maxint()
  149. {
  150.   ptr_psi_term t,result;
  151.   REAL val;
  152.   long num,success;
  153.   
  154.   t=aim->a;
  155.   deref_args(t,set_empty);
  156.   result=aim->b;
  157.   deref_ptr(result);
  158.   success=get_real_value(result,&val,&num);
  159.   if (success) {
  160.     if (num)
  161.       success=(val==(REAL)WL_MAXINT);
  162.     else
  163.       success=unify_real_result(result,(REAL)WL_MAXINT);
  164.   }
  165.   return success;
  166. }
  167.  
  168.  
  169.  
  170. /* 21.1 */
  171. /******** C_QUIET
  172.   Return the value of not(NOTQUIET).
  173.   */
  174. long c_quiet()
  175. {
  176.   ptr_psi_term t,result,ans;
  177.   int success=TRUE;
  178.   
  179.   t=aim->a;
  180.   deref_args(t,set_empty);
  181.   result=aim->b;
  182.   deref_ptr(result);
  183.   ans=stack_psi_term(4);
  184.   ans->type = NOTQUIET ? false : true;
  185.   push_goal(unify,result,ans,NULL);
  186.   return success;
  187. }
  188.  
  189.  
  190.  
  191. /******** C_CPUTIME
  192.   Return the cpu-time in seconds used by the Wild_Life interpreter.
  193. */
  194. static long c_cputime()
  195. {
  196.   ptr_psi_term result, t;
  197.   REAL thetime,val;
  198.   long num,success;
  199.   
  200.   t=aim->a;
  201.   deref_args(t,set_empty);
  202.   result=aim->b;
  203.   deref_ptr(result);
  204.   success=get_real_value(result,&val,&num);
  205.   if (success) {
  206.     times(&life_end);
  207. #ifndef OS2_PORT
  208.     thetime=(life_end.tms_utime-life_start.tms_utime)/60.0;
  209. #else
  210.     thetime=(life_end-life_start)/60.0;
  211. #endif
  212.  
  213.     if (num)
  214.       success=(val==thetime);
  215.     else
  216.       success=unify_real_result(result,thetime);
  217.   }
  218.   return success;
  219. }
  220.  
  221. /******** C_REALTIME
  222.   Return the time in seconds since 00:00:00 GMT, January 1, 1970.
  223.   This is useful for building real-time applications such as clocks.
  224. */
  225. static long c_realtime()
  226. {
  227.   ptr_psi_term result, t;
  228.   REAL thetime,val;
  229.   long num,success;
  230. #ifndef OS2_PORT
  231.   struct timeval tp;
  232.   struct timezone tzp;
  233. #else
  234.   time_t tp;
  235.   float part_sec;
  236. #endif
  237.   
  238.   t=aim->a;
  239.   deref_args(t,set_empty);
  240.   result=aim->b;
  241.   deref_ptr(result);
  242.   success=get_real_value(result,&val,&num);
  243.   if (success) {
  244. #ifndef OS2_PORT
  245.     gettimeofday(&tp, &tzp);
  246.     thetime=(REAL)tp.tv_sec + ((REAL)tp.tv_usec/1000000.0);
  247.     /* thetime=times(&life_end)/60.0; */
  248. #else
  249.     time(&tp);
  250.     thetime = (REAL) tp;
  251. #endif
  252.     if (num)
  253.       success=(val==thetime);
  254.     else
  255.       success=unify_real_result(result,thetime);
  256.   }
  257.   return success;
  258. }
  259.  
  260. /******** C_LOCALTIME
  261.   Return a psi-term containing the local time split up into year, month, day,
  262.   hour, minute, second, and weekday.
  263.   This is useful for building real-time applications such as clocks.
  264. */
  265. static long c_localtime()
  266. {
  267.   ptr_psi_term result, t, psitime;
  268.   long success=TRUE;
  269. #ifndef OS2_PORT
  270.   struct timeval tp;
  271.   struct timezone tzp;
  272. #else
  273.    time_t tp;
  274. #endif
  275.   struct tm *thetime;
  276.   
  277.   t=aim->a;
  278.   deref_args(t,set_empty);
  279.   result=aim->b;
  280.   deref_ptr(result);
  281.  
  282. #ifndef OS2_PORT
  283.   gettimeofday(&tp, &tzp);
  284.   thetime=localtime((time_t *) &(tp.tv_sec));
  285. #else
  286.   time(&tp);
  287.   thetime = localtime((time_t *) &tp);
  288. #endif  
  289.  
  290.   psitime=stack_psi_term(4);
  291.   psitime->type=timesym;
  292.   stack_add_int_attr(psitime, year_attr,    thetime->tm_year+1900);
  293.   stack_add_int_attr(psitime, month_attr,   thetime->tm_mon+1);
  294.   stack_add_int_attr(psitime, day_attr,     thetime->tm_mday);
  295.   stack_add_int_attr(psitime, hour_attr,    thetime->tm_hour);
  296.   stack_add_int_attr(psitime, minute_attr,  thetime->tm_min);
  297.   stack_add_int_attr(psitime, second_attr,  thetime->tm_sec);
  298.   stack_add_int_attr(psitime, weekday_attr, thetime->tm_wday);
  299.  
  300.   push_goal(unify,result,psitime,NULL);
  301.  
  302.   return success;
  303. }
  304.  
  305. /******** C_STATISTICS
  306.   Print some information about Wild_Life: stack size, heap size, total memory.
  307. */
  308. static long c_statistics()
  309. {
  310.   ptr_psi_term t;
  311.   long success=TRUE;
  312.   long t1,t2,t3;
  313.  
  314.   t=aim->a;
  315.   deref_args(t,set_empty);
  316.  
  317.   t1 = sizeof(mem_base)*(stack_pointer-mem_base);
  318.   t2 = sizeof(mem_base)*(mem_limit-heap_pointer);
  319.   t3 = sizeof(mem_base)*(mem_limit-mem_base);
  320.  
  321.   printf("\n");
  322.   /* printf("************** SYSTEM< INFORMATION **************\n"); */
  323.   printf("Stack size  : %8d bytes (%5dK) (%ld%%)\n",t1,t1/1024,100*t1/t3);
  324.   printf("Heap size   : %8d bytes (%5dK) (%ld%%)\n",t2,t2/1024,100*t2/t3);
  325.   printf("Total memory: %8d bytes (%5dK)\n",t3,t3/1024);
  326.  
  327. #ifdef X11
  328.   printf("X predicates are installed.\n");
  329. #else
  330.   printf("X predicates are not installed.\n");
  331. #endif
  332.   
  333.   /* printf("\n"); */
  334.   /* printf("************************************************\n"); */
  335.   return success;
  336. }
  337.  
  338.  
  339. /******** C_GARBAGE
  340.   Force a call to the garbage collector.
  341. */
  342. static long c_garbage()
  343. {
  344.   ptr_psi_term t;
  345.  
  346.   t=aim->a;
  347.   deref_args(t,set_empty);
  348.   garbage();
  349.   return TRUE;
  350. }
  351.  
  352.  
  353. /******** C_GETENV
  354.   Get the value of an environment variable.
  355. */
  356. static long c_getenv()
  357. {
  358.   long success=FALSE;
  359.   ptr_psi_term arg1,arg2,funct,result,t;
  360.   int smaller;
  361.   
  362.   funct = aim->a;
  363.   result=aim->b;
  364.   deref_ptr(funct);
  365.   deref_ptr(result);
  366.   
  367.   get_two_args(funct->attr_list, &arg1, &arg2);
  368.   if(arg1) {
  369.     deref_ptr(arg1);
  370.     if(matches(arg1->type,quoted_string,&smaller) && arg1->value) {
  371.       char *s=(char *)getenv((char *)arg1->value);
  372.       if(s) {
  373.     success=TRUE;
  374.     t=stack_psi_term(4);
  375.     t->type=quoted_string;
  376.     t->value=(GENERIC)heap_copy_string(s);
  377.     push_goal(unify,result,t,NULL);
  378.       }
  379.     }
  380.     else
  381.       Errorline("bad argument in %P\n",funct);
  382.   }
  383.   else
  384.     Errorline("argument missing in %P\n",funct);
  385.   
  386.   return success;
  387. }
  388.  
  389.  
  390. /******** C_SYSTEM
  391.   Pass a string to shell for execution. Return the value as the result.
  392. */
  393. static long c_system()
  394. {
  395.   long success=TRUE;
  396.   ptr_psi_term arg1,arg2,funct,result;
  397.   REAL value;
  398.   long smaller;
  399.   
  400.   funct=aim->a;
  401.   deref_ptr(funct);
  402.   result=aim->b;
  403.   get_two_args(funct->attr_list,&arg1,&arg2);
  404.   if(arg1) {
  405.     deref(arg1);
  406.     deref_args(funct,set_1);
  407.     if((success=matches(arg1->type,quoted_string,&smaller)))
  408.       if(arg1->value) {
  409.     value=(REAL)system((char *)arg1->value);
  410.     if(value==127) {
  411.       success=FALSE;
  412.           Errorline("could not execute shell in %P.\n",funct);
  413.       /* report_error(funct,"couldn't execute shell"); */
  414.     }
  415.     else
  416.       success=unify_real_result(result,value);
  417.       }
  418.       else {
  419.     /* residuate(arg1); */ /*  RM: Feb 10 1993  */
  420.         success=FALSE;
  421.         Errorline("bad argument in %P.\n",funct);
  422.       }
  423.     else {
  424.       success=FALSE;
  425.       Errorline("bad argument in %P.\n",funct);
  426.       /* report_error(funct,"bad argument"); */
  427.     }
  428.   }
  429.   else
  430.     curry();
  431.   
  432.   return success;
  433. }
  434.  
  435. /******** C_ENCODE
  436.   Force type encoding.
  437.   This need normally never be called by the user.
  438. */
  439. static long c_encode()
  440. {
  441.   ptr_psi_term t;
  442.  
  443.   t=aim->a;
  444.   deref_args(t,set_empty);
  445.   encode_types();
  446.   return TRUE;
  447. }
  448.  
  449. static GENERIC unitListElement;
  450.  
  451. void setUnitList(x)
  452. GENERIC x;
  453. {
  454.     unitListElement = x;
  455. }
  456.  
  457. ptr_psi_term unitListValue()
  458. {
  459.     return makePsiTerm((void *)unitListElement);
  460. }
  461.  
  462. GENERIC unitListNext()
  463. {
  464.     unitListElement = NULL;
  465.     return NULL;
  466. }
  467.  
  468. ptr_psi_term intListValue(p)
  469. ptr_int_list p;
  470. {
  471.     return makePsiTerm((void *)p->value);
  472. }
  473.  
  474. GENERIC intListNext(p)
  475. ptr_int_list p;
  476. {
  477.     return (GENERIC )(p->next);
  478. }
  479.  
  480. ptr_psi_term quotedStackCopy(p)
  481. ptr_psi_term p;
  482. {
  483.     ptr_psi_term q;
  484.  
  485.     q = stack_copy_psi_term(p);
  486.     mark_quote(q);
  487.     return q;
  488. }
  489.  
  490. /* Return a ptr to a psi-term marked as  evaluated.  The psi-term is a copy at
  491.  * the top level of the goal residuated on p, with the rest of the psi-term
  492.  * shared.
  493.  */
  494.  
  495. ptr_psi_term residListGoalQuote(p)
  496. ptr_residuation p;
  497. {
  498.     ptr_psi_term psi;
  499.  
  500.     psi = stack_psi_term(4);
  501.     copyPsiTerm(psi, p->goal->a);
  502.     psi->status = 4;
  503.     return psi;
  504. }
  505.  
  506. GENERIC residListNext(p)
  507. ptr_residuation p;
  508. {
  509.     return (GENERIC )(p->next);
  510. }
  511.  
  512. ptr_psi_term makePsiTerm(x)
  513. ptr_definition x;
  514. {
  515.     ptr_psi_term p;
  516.     
  517.     p = stack_psi_term(4);
  518.     p->type = x;
  519.     return p;
  520. }
  521.  
  522.  
  523.  
  524. ptr_psi_term makePsiList(head, valueFunc, nextFunc)
  525.      
  526.      GENERIC head;
  527.      ptr_psi_term (*valueFunc)();
  528.      GENERIC (*nextFunc)();
  529. {
  530.   ptr_psi_term result;
  531.  
  532.   
  533.   /*  RM: Dec 14 1992: Added the new list representation  */
  534.   result=stack_nil();
  535.   
  536.   while (head) {
  537.     result=stack_cons((*valueFunc)(head),result);
  538.     head=(*nextFunc)(head);
  539.   }
  540.   return result;
  541. }
  542.  
  543.  
  544.  
  545. /******** C_ResidList
  546.   rlist(A) ->  list all eval/prove goals residuated on variable 'A'.
  547. */
  548. static long c_residList()
  549. {
  550.     ptr_psi_term func;
  551.     ptr_psi_term result,arg1, other;
  552.     
  553.     func = aim->a;
  554.     deref_ptr(func);
  555.  
  556.     get_one_arg(func->attr_list, &arg1);
  557.     if (!arg1)
  558.     {
  559.         curry();
  560.         return TRUE;
  561.     }
  562.     
  563.     result = aim->b;
  564.     deref(result);
  565.     deref_ptr(arg1);
  566.     deref_args(func, set_1);
  567.  
  568.     other = makePsiList((void *)arg1->resid,
  569.                 residListGoalQuote,
  570.                 residListNext);
  571.     resid_aim = NULL;
  572.     push_goal(unify,result,other,NULL);
  573.     return TRUE;
  574. }
  575.  
  576.  
  577. ptr_goal makeGoal(p)
  578. ptr_psi_term p;
  579. {
  580.     ptr_goal old = goal_stack;
  581.     ptr_goal g;
  582.     
  583.     push_goal(prove, p, DEFRULES, NULL);
  584.     g = goal_stack;
  585.     g->next=NULL;
  586.     goal_stack = old;
  587.     return g;
  588. }
  589.  
  590.  
  591. /******** C_residuate
  592.   residuate(A,B) ->  residuate goal B on variable A, non_strict in both args
  593. */
  594. static long c_residuate()
  595. {
  596.     ptr_psi_term pred;
  597.     ptr_psi_term arg1, arg2;
  598.     ptr_goal g;
  599.     
  600.     pred = aim->a;
  601.     deref_ptr(pred);
  602.  
  603.     get_two_args(pred->attr_list, &arg1, &arg2);
  604.     if ((!arg1)||(!arg2)) {
  605.       Errorline("%P requires two arguments.\n",pred);
  606.       return FALSE;
  607.         }
  608.     
  609.     deref_ptr(arg1);
  610.     deref_ptr(arg2);
  611.     deref_args(pred, set_1_2);
  612.  
  613.     g = makeGoal(arg2);
  614.     residuateGoalOnVar(g, arg1, NULL);
  615.     
  616.     return TRUE;
  617. }
  618.  
  619. /******** C_mresiduate
  620.   Multiple-variable residuation of a predicate.
  621.   mresiduate(A,B) ->  residuate goal B on a list of variables A, non_strict in
  622.   both args.  If any of the variables is bound the predicate is executed.
  623.   The list must have finite length.
  624. */
  625. static long c_mresiduate()
  626.      
  627. {
  628.   long success=TRUE;
  629.   ptr_psi_term pred;
  630.   ptr_psi_term arg1, arg2, tmp, var;
  631.   ptr_goal g;
  632.   
  633.   pred = aim->a;
  634.   deref_ptr(pred);
  635.   
  636.   get_two_args(pred->attr_list, &arg1, &arg2);
  637.   if ((!arg1)||(!arg2)) {
  638.     Errorline("%P requires two arguments.\n",pred);
  639.     return FALSE;
  640.   }
  641.   
  642.   deref_ptr(arg1);
  643.   deref_ptr(arg2);
  644.   deref_args(pred, set_1_2);
  645.   
  646.   g = makeGoal(arg2);
  647.   
  648.   /* Then residuate on all the list variables: */
  649.   tmp=arg1;
  650.   while(tmp && tmp->type==alist) { /*  RM: Dec 14 1992  */
  651.     get_two_args(tmp->attr_list,&var,&tmp);
  652.     if(var) {
  653.       deref_ptr(var);
  654.       residuateGoalOnVar(g,var,NULL);
  655.     }
  656.     if(tmp)
  657.       deref_ptr(tmp);
  658.   }
  659.   
  660.   if(!tmp || tmp->type!=nil) {
  661.     Errorline("%P should be a nil-terminated list in mresiduate.\n",arg1);
  662.     success=FALSE;
  663.   }
  664.  
  665.   return success;
  666. }
  667.  
  668.  
  669.  
  670. void insert_system_builtins()
  671. {
  672.   new_built_in(bi_module,"trace",predicate,c_trace);
  673.   new_built_in(bi_module,"step",predicate,c_step);
  674.   new_built_in(bi_module,"verbose",predicate,c_verbose);
  675.   new_built_in(bi_module,"warning",predicate,c_warning);
  676.   new_built_in(bi_module,"maxint",function,c_maxint);
  677.   new_built_in(bi_module,"cpu_time",function,c_cputime);
  678.   new_built_in(bi_module,"quiet",function,c_quiet); /* 21.1 */
  679.   new_built_in(bi_module,"real_time",function,c_realtime);
  680.   new_built_in(bi_module,"local_time",function,c_localtime);
  681.   new_built_in(bi_module,"statistics",predicate,c_statistics);
  682.   new_built_in(bi_module,"gc",predicate,c_garbage);
  683.   new_built_in(bi_module,"system",function,c_system);
  684.   new_built_in(bi_module,"getenv",function,c_getenv);
  685.   new_built_in(bi_module,"encode",predicate,c_encode);
  686.   new_built_in(bi_module,"rlist",function,c_residList);
  687.   new_built_in(bi_module,"residuate",predicate,c_residuate);
  688.   new_built_in(bi_module,"mresiduate",predicate,c_mresiduate);
  689.   new_built_in(bi_module,"tprove",predicate,c_tprove);
  690. }
  691.