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