Wild Life: sys.c Source File

Wild Life 2.30

- Main Page
- Data Structures
- Files

- File List
- Globals

All Data Structures Files Functions Variables Typedefs Macros
sys.c
Go to the documentation of this file.
1
9 /* Copyright by Denys Duchier, Dec 1994
10 Simon Fraser University
11 */
12
13 #include "defs.h"
14
24 long call_primitive(long (*fun)(),int num,psi_arg argi[],GENERIC info)
25 {
26 ptr_psi_term funct,arg,result,argo[ARGNN]; /* no more than 10 arguments */
27 ptr_node n;
28 int allargs=1,allvalues=1,i;
29 funct=aim->aaaa_1;
30 deref_ptr(funct);
31 result=aim->bbbb_1;
32 for (i=0;i<num;i++) {
33 n=find(FEATCMP,argi[i].feature,funct->attr_list);
34 /* argument present */
35 if (n) {
36 arg = (ptr_psi_term) n->data;
37 /* in case we don't want to evaluate the argument
38 just follow the chain of corefs and don't do
39 any of the other checks: they'll have do be done
40 by fun; just go on to the next arg */
41 if (argi[i].options&UNEVALED) {
42 deref_ptr(arg);
43 argo[i]=arg;
44 continue; }
45 /* this arg should be evaled */
46 deref(arg);
47 argo[i]=arg;
48 /* arg of admissible type */
49 if (argi[i].options&POLYTYPE) {
50 ptr_definition *type = (ptr_definition *)argi[i].type;
51 while (*type != NULL)
52 if (overlap_type(arg->type,*type))
53 goto admissible;
54 else type++;
55 }
56 else {
57 if (overlap_type(arg->type,argi[i].type))
58 goto admissible;
59 }
60 /* not admissible */
61 if (argi[i].options&JUSTFAIL) return FALSE;
62 Errorline("Illegal argument in %P.\n",funct);
63 return (c_abort());
64 /* admissible */
65 admissible:
66 /* has value */
67 if (arg->value_3) {
68 ptr_definition *type = (ptr_definition *)argi[i].type;
69 /* paranoid check: really correct type */
70 if (argi[i].options&POLYTYPE) {
71 while (*type != NULL)
72 if (sub_type(arg->type,*type))
73 goto correct;
74 else type++;
75 }
76 else {
77 if (sub_type(arg->type,(ptr_definition)type)) goto correct;
78 }
79 /* type incorrect */
80 if (argi[i].options&JUSTFAIL) return FALSE;
81 Errorline("Illegal argument in %P.\n",funct);
82 return (c_abort());
83 /* correct */
84 correct:;
85 }
86 /* missing value - do we need it */
87 else if (!(argi[i].options&NOVALUE)) allvalues=0;
88 }
89 /* argument missing */
90 else {
91 argo[i]=NULL;
92 if (argi[i].options&MANDATORY) {
93 Errorline("Missing argument '%s' in %P.\n",argi[i].feature,funct);
94 return (c_abort());
95 }
96 else if (argi[i].options&REQUIRED) allargs=0;
97 }
98 }
99 if (allargs)
100 if (allvalues) {
101 return fun(argo,result,funct,info);
102 }
103 else {
104 for (i=0;i<num;i++) {
105 /* if arg present and should be evaled but has no value */
106 if (argo[i] && !(argi[i].options&UNEVALED) && !argo[i]->value_3)
107 residuate(argo[i]);
108 }
109 }
110 else curry();
111 return TRUE;
112 }
113
114 /* DENYS: BYTEDATA */
115
126 static ptr_psi_term make_bytedata(ptr_definition sort,unsigned long bytes)
127 {
128 ptr_psi_term temp_result;
129 char *b = (char *) heap_alloc(bytes+sizeof(bytes));
130 *((long *) b) = bytes;
131 bzero(b+sizeof(bytes),bytes);
132 temp_result=stack_psi_term(0);
133 temp_result->type=sort;
134 temp_result->value_3=(GENERIC)b;
135 return temp_result;
136 }
137
138 #define BYTEDATA_SIZE(X) (*(unsigned long *)(X->value_3))
139 #define BYTEDATA_DATA(X) ((char*)((char*)X->value_3 + sizeof(unsigned long)))
140
141 /* BIT VECTORS *
142 ***************/
143
154 static long make_bitvector_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
155 {
156 long bits = *(REAL *)args[0]->value_3;
157 if (bits < 0) {
158 Errorline("negative argument in %P.\n",funct);
159 return FALSE; }
160 else {
161 unsigned long bytes = bits / sizeof(char);
162 ptr_psi_term temp_result;
163 if ((bits % sizeof(char)) != 0) bytes++;
164 temp_result = make_bytedata(sys_bitvector,bytes);
165 push_goal(unify,temp_result,result,NULL);
166 return TRUE; }
167 }
168
174 static long c_make_bitvector()
175 {
176 psi_arg args[1];
177 SETARG(args,0, "1" , integer , REQUIRED );
178 return call_primitive(make_bitvector_internal,NARGS(args),args,0);
179 }
180
181 #define BV_AND 0
182 #define BV_OR 1
183 #define BV_XOR 2
184
194 static long bitvector_binop_code(unsigned long *bv1,unsigned long *bv2,ptr_psi_term result,GENERIC op)
195 {
196 unsigned long size1 = *bv1;
197 unsigned long size2 = *bv2;
198 unsigned long size3 = (size1>size2)?size1:size2;
199 ptr_psi_term temp_result = make_bytedata(sys_bitvector,size3);
200 unsigned char *s1 = ((unsigned char*)bv1)+sizeof(size1);
201 unsigned char *s2 = ((unsigned char*)bv2)+sizeof(size2);
202 unsigned char *s3 = ((unsigned char *) temp_result->value_3) + sizeof(size3);
203 unsigned long i;
204 switch ((long)op) { // added cast DJD 2.16
205 case BV_AND:
206 for(i=0;i<size3;i++) s3[i] = s1[i] & s2[i];
207 if (size1<size2) for(;i<size2;i++) s3[i] = 0;
208 else for(;i<size1;i++) s3[i] = 0;
209 break;
210 case BV_OR:
211 for(i=0;i<size3;i++) s3[i] = s1[i] | s2[i];
212 if (size1<size2) for(;i<size2;i++) s3[i] = s2[i];
213 else for(;i<size1;i++) s3[i] = s1[i];
214 break;
215 case BV_XOR:
216 for(i=0;i<size3;i++) s3[i] = s1[i] ^ s2[i];
217 if (size1<size2) for(;i<size2;i++) s3[i] = (unsigned char) 0 ^ s2[i];
218 else for(;i<size1;i++) s3[i] = s1[i] ^ (unsigned char) 0;
219 break;
220 default: return (c_abort());
221 }
222 push_goal(unify,temp_result,result,NULL);
223 return TRUE;
224 }
225
235 static long bitvector_binop_internal(ptr_psi_term *args,ptr_psi_term result,ptr_psi_term funct,GENERIC op)
236 {
237 return bitvector_binop_code((unsigned long *)args[0]->value_3,
238 (unsigned long *)args[1]->value_3,
239 result,(GENERIC)op);
240 }
241
248 static long bitvector_binop(long op)
249 {
250 psi_arg args[2];
251 SETARG(args,0, "1" , sys_bitvector , REQUIRED );
252 SETARG(args,1, "2" , sys_bitvector , REQUIRED );
253 return call_primitive(bitvector_binop_internal,NARGS(args),args,(GENERIC)op);
254 }
255
261 static long c_bitvector_and()
262 {
263 return bitvector_binop(BV_AND);
264 }
265
271 static long c_bitvector_or()
272 {
273 return bitvector_binop(BV_OR);
274 }
275
281 static long c_bitvector_xor()
282 {
283 return bitvector_binop(BV_XOR);
284 }
285
286 #define BV_NOT 0
287 #define BV_COUNT 1
288
297 static long bitvector_unop_code(unsigned long *bv1,ptr_psi_term result,int op)
298 {
299 unsigned long size1 = *bv1;
300 unsigned char *s1 = ((unsigned char*)bv1)+sizeof(size1);
301 unsigned long i;
302 ptr_psi_term temp_result;
303 unsigned char *s3;
304 switch (op) {
305 case BV_NOT:
306 temp_result = make_bytedata(sys_bitvector,size1);
307 s3 = ((unsigned char *) temp_result->value_3) + sizeof(size1);
308 for(i=0;i<size1;i++) s3[i] = ~(s1[i]);
309 break;
310 case BV_COUNT:
311 {
312 int cnt = 0;
313 register unsigned char c;
314 for(i=0;i<size1;i++) {
315 c=s1[i];
316 if (c & 1<<0) cnt++;
317 if (c & 1<<1) cnt++;
318 if (c & 1<<2) cnt++;
319 if (c & 1<<3) cnt++;
320 if (c & 1<<4) cnt++;
321 if (c & 1<<5) cnt++;
322 if (c & 1<<6) cnt++;
323 if (c & 1<<7) cnt++; }
324 return unify_real_result(result,(REAL) cnt);
325 }
326 break;
327 default: return (c_abort());
328 }
329 push_goal(unify,temp_result,result,NULL);
330 return TRUE;
331 }
332
343 static long bitvector_unop_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct,int op)
344 {
345 return bitvector_unop_code((unsigned long *)args[0]->value_3,result, op);
346 }
347
354 static long bitvector_unop(GENERIC op)
355 {
356 psi_arg args[1];
357 SETARG(args,0, "1" , sys_bitvector , REQUIRED );
358 return call_primitive(bitvector_unop_internal,NARGS(args),args,op);
359 }
360
366 static long c_bitvector_not()
367 {
368 return bitvector_unop((GENERIC)BV_NOT); // cast added 12/10/2016 DJD 2.29
369 }
370
376 static long c_bitvector_count()
377 {
378 return bitvector_unop((GENERIC)BV_COUNT); // cast added 12/10/2016 DJD 2.29
379 }
380
381 #define BV_GET 0
382 #define BV_SET 1
383 #define BV_CLEAR 2
384
395 static long bitvector_bit_code(unsigned long *bv1,long idx,ptr_psi_term result,int op,ptr_psi_term funct)
396 {
397 unsigned long size1 = *bv1;
398 unsigned char *s1 = ((unsigned char*)bv1)+sizeof(size1);
399 unsigned long i = idx / sizeof(char);
400 int j = idx % sizeof(char);
401 ptr_psi_term temp_result;
402 unsigned char *s2;
403 if (idx<0 || idx>=size1) {
404 Errorline("Index out of bound in %P.\n",funct);
405 return FALSE; }
406 switch (op) {
407 case BV_GET:
408 return unify_real_result(result,(REAL)((s1[i] & (1<<j))?1:0));
409 break;
410 case BV_SET:
411 temp_result = make_bytedata(sys_bitvector,size1);
412 s2 = ((unsigned char *) temp_result->value_3) + sizeof(size1);
413 bcopy(s1,s2,size1);
414 s2[i] |= 1<<j;
415 break;
416 case BV_CLEAR:
417 temp_result = make_bytedata(sys_bitvector,size1);
418 s2 = ((unsigned char *) temp_result->value_3) + sizeof(size1);
419 bcopy(s1,s2,size1);
420 s2[i] &= ~ (1<<j);
421 break;
422 }
423 push_goal(unify,temp_result,result,NULL);
424 return TRUE;
425 }
426
436 static long bitvector_bit_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct,int op)
437 {
438 return bitvector_bit_code((unsigned long *)args[0]->value_3,
439 (long)*((REAL*)args[1]->value_3),
440 result,op,funct);
441 }
442
449 static long bitvector_bit(long op)
450 {
451 psi_arg args[2];
452 SETARG(args,0, "1" , sys_bitvector , REQUIRED );
453 SETARG(args,1, "2" , integer , REQUIRED );
454 return call_primitive(bitvector_bit_internal,NARGS(args),args,(GENERIC)op);
455 }
456
462 static long c_bitvector_get()
463 {
464 return bitvector_bit(BV_GET);
465 }
466
472 static long c_bitvector_set()
473 {
474 return bitvector_bit(BV_SET);
475 }
476
482 static long c_bitvector_clear()
483 {
484 return bitvector_bit(BV_CLEAR);
485 }
486
487 /* REGULAR EXPRESSIONS *
488 ***********************/
489
490 #include "regexp/regexp.h"
491
498 void regerror(char *s)
499 {
500 fprintf(stderr,"Regexp Error: %s\n",s);
501 }
502
514 static long regexp_compile_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
515 {
516 ptr_psi_term temp_result;
517 regexp * re = regcomp((char *)args[0]->value_3);
518 long bytes;
519 if (re == NULL) {
520 Errorline("compilation of regular expression failed in %P.\n",funct);
521 return (c_abort()); }
522 /* compute the size of the regexp stuff. this is essentially the size
523 of the regexp structure + the size of the program (bytecode) including
524 the final END opcode (i.e. 0), hence the + 1, minus the bytes that we
525 have counted twice, i.e. those between the start of the program and
526 the computed end of the regexp structure (i.e. in case a regexp
527 struct is larger, maybe to respect alignment constraints, than it has
528 to be, and also to count the 1 byte of program included in the decl
529 of struct regexp */
530 bytes = last_regsize();
531 temp_result = make_bytedata(sys_regexp,bytes);
532 /* now let's copy the regexp stuff into the bytedata block. The regmust
533 field must be treated specially because it is a pointer into program:
534 we cannot simply change it to reflect the location where the program
535 will be copied to because that may well change over time: the gc may
536 relocate the bytedata block. Instead, we convert regmust into an
537 offset and each time we need to pass it to regexec or regsub we must
538 first convert it back into a pointer then back into an offset when we
539 are done. Note that, if regmust is NULL we must leave it that way */
540 if (re->regmust != NULL)
541 re->regmust = (char *) ((unsigned long) (re->regmust - (char *)re));
542 bcopy((char*)re,((char*)temp_result->value_3)+sizeof(unsigned long),bytes);
543 free(re); /* free the regexp: no longer needed */
544 /* return result */
545 push_goal(unify,temp_result,result,NULL);
546 return TRUE;
547 }
548
554 static long c_regexp_compile()
555 {
556 psi_arg args[1];
557 SETARG(args,0, "1" , quoted_string , REQUIRED );
558 return call_primitive(regexp_compile_internal,NARGS(args),args,0);
559 }
560
576 static long regexp_execute_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
577 {
578 regexp * re = (regexp*)(((char *)args[0]->value_3)+sizeof(unsigned long));
579 char * must = re->regmust;
580 long offset = 0;
581 // long success = TRUE;
582 /* check that args[3] aka "offset" is valid if present */
583 if (args[3]) {
584 offset = *(REAL*)args[3]->value_3;
585 if (offset < 0 || offset > strlen((char*)args[1]->value_3)) {
586 Errorline("Illegal offset in %P.\n",funct);
587 return (c_abort()); }
588 }
589 /* convert regmust from offset into a pointer if not NULL */
590 if (must != NULL)
591 re->regmust = (char*)re+(unsigned long)must;
592 /* perform operation */
593 if (regexec(re,((char *)args[1]->value_3) + offset) == 0) {
594 if (must != NULL) re->regmust = must; /* back into an offset */
595 return FALSE;
596 }
597 else {
598 /* construct result of match */
599 char **sp = re->startp;
600 char **ep = re->endp;
601 int i;
602 char buffer_loc[5]; /* in case NSUBEXP ever gets increased */
603 ptr_node n3;
604 if (must != NULL) re->regmust = must; /* back into an offset */
605 if (args[2]) {
606 /* only instantiate the numeric features present in args[2]
607 then return true */
608 for (i=0;i<NSUBEXP;i++,sp++,ep++) {
609 if (*sp==NULL) break;
610 (void)snprintf(buffer_loc,5,"%d",i);
611 n3=find(FEATCMP,buffer_loc,args[2]->attr_list);
612 if (n3) {
613 ptr_psi_term psi = (ptr_psi_term) n3->data;
614 /* need to add 1 to these offsets because somehow life strings
615 are 1-based rather than 0-based. Who is the moron who made
616 that decision? This isn't Pascal! */
617 ptr_psi_term bounds = stack_pair(stack_int(*sp - (char *)args[1]->value_3 + 1),
618 stack_int(*ep - (char *)args[1]->value_3 + 1));
619 push_goal(unify,psi,bounds,NULL);
620 }
621 }
622 /* return true */
623 unify_bool_result(result,TRUE);
624 }
625 else {
626 /* create a term to represent all the groups and return it */
627 ptr_psi_term psi = stack_psi_term(4);
628 psi->type = top;
629 for (i=0;i<NSUBEXP;i++,sp++,ep++) {
630 if (*sp==NULL) break;
631 (void)snprintf(buffer_loc,5,"%d",i);
632 { ptr_psi_term bounds = stack_pair(stack_int(*sp - (char *)args[1]->value_3 + 1),
633 stack_int(*ep - (char *)args[1]->value_3 + 1));
634 stack_insert_copystr(buffer_loc,&(psi->attr_list),(GENERIC)bounds); }
635 }
636 /* return the new term */
637 push_goal(unify,psi,result,NULL);
638 }
639 return TRUE;
640 }
641 }
642
648 static long c_regexp_execute()
649 {
650 psi_arg args[4];
651 SETARG(args,0, "1" , sys_regexp , REQUIRED );
652 SETARG(args,1, "2" , quoted_string , REQUIRED );
653 SETARG(args,2, "3" , top , OPTIONAL|NOVALUE );
654 SETARG(args,3, "offset" , integer , OPTIONAL );
655 return call_primitive(regexp_execute_internal,NARGS(args),args,0);
656 }
657
658 /* FILE STREAMS *
659 ****************/
660
661 /* when a fp is opened for updating an input operation
662 should not follow an output operation without an intervening
663 flush or file positioning operation; and the other way around
664 too. I am going to keep track of what operations have been
665 applied so that flush will be automatically invoked when
666 necessary */
667
668 #define FP_NONE 0
669 #define FP_INPUT 1
670 #define FP_OUTPUT 2
671
672 typedef struct a_stream {
673 FILE *fp;
674 int op;
675 } *ptr_stream;
676
677 #define FP_PREPARE(s,OP) \
678 if (s->op != OP && s->op != FP_NONE) fflush(s->fp); \
679 s->op = OP;
680
688 ptr_psi_term fileptr2stream(FILE *fp,ptr_definition typ)
689 {
690 ptr_psi_term result = make_bytedata(typ,sizeof(struct a_stream));
691 ((ptr_stream)BYTEDATA_DATA(result))->fp = fp;
692 ((ptr_stream)BYTEDATA_DATA(result))->op = FP_NONE;
693 return result;
694 }
695
704 static long int2stream_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
705 {
706 FILE *fp = fdopen((int)*(REAL*)args[0]->value_3,
707 (char*)args[1]->value_3);
708 if (fp==NULL) return FALSE;
709 else {
710 push_goal(unify,fileptr2stream(fp,sys_stream),result,NULL); // added & DJD
711 /* ptr_psi_term temp_result = make_bytedata(sys_stream,sizeof(fp));
712 *(FILE**)BYTEDATA_DATA(temp_result) = fp;
713 push_goal(unify,temp_result,result,NULL); */
714 return TRUE;
715 }
716 }
717
723 static long c_int2stream()
724 {
725 psi_arg args[2];
726 SETARG(args,0,"1",integer,REQUIRED);
727 SETARG(args,1,"2",quoted_string,REQUIRED);
728 return call_primitive(int2stream_internal,NARGS(args),args,0);
729 }
730
739 static long fopen_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
740 {
741 FILE *fp = fopen((char*)args[0]->value_3,
742 (char*)args[1]->value_3);
743 if (fp==NULL) return FALSE;
744 else {
745 /* ptr_psi_term temp_result = make_bytedata(sys_file_stream,sizeof(fp));
746 *(FILE**)BYTEDATA_DATA(temp_result) = fp;
747 */
748 push_goal(unify,fileptr2stream(fp,sys_file_stream),result,NULL); // added & DJD
749 return TRUE;
750 }
751 }
752
758 static long c_fopen()
759 {
760 psi_arg args[2];
761 SETARG(args,0, "1" , quoted_string , REQUIRED );
762 SETARG(args,1, "2" , quoted_string , REQUIRED );
763 return call_primitive(fopen_internal,NARGS(args),args,0);
764 }
765
774 static long fclose_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
775 {
776 if (fclose(((ptr_stream)BYTEDATA_DATA(args[0]))->fp) != 0)
777 return FALSE;
778 else
779 return TRUE;
780 }
781
787 static long c_fclose()
788 {
789 psi_arg args[1];
790 SETARG(args,0, "1" , sys_stream , REQUIRED );
791 return call_primitive(fclose_internal,NARGS(args),args,0);
792 }
793
802 static long fwrite_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
803 {
804 ptr_stream srm = (ptr_stream)BYTEDATA_DATA(args[0]);
805 /*FILE* fp = *(FILE**)BYTEDATA_DATA(args[0]);*/
806 char* txt = (char*)args[1]->value_3;
807 FP_PREPARE(srm,FP_OUTPUT);
808 if (txt && *txt!='\0' &&
809 fwrite((void*)txt,sizeof(char),strlen(txt),srm->fp)<=0)
810 return FALSE;
811 return TRUE;
812 }
813
819 static long c_fwrite()
820 {
821 psi_arg args[2];
822 SETARG(args,0,"1",sys_stream,MANDATORY);
823 SETARG(args,1,"2",quoted_string,MANDATORY);
824 return call_primitive(fwrite_internal,NARGS(args),args,0);
825 }
826
835 static long fflush_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
836 {
837 ptr_stream srm = (ptr_stream)BYTEDATA_DATA(args[0]);
838 /*FILE* fp = *(FILE**)BYTEDATA_DATA(args[0]);*/
839 srm->op = FP_NONE;
840 if (fflush(srm->fp)!=0) return FALSE;
841 return TRUE;
842 }
843
849 static long c_fflush()
850 {
851 psi_arg args[1];
852 SETARG(args,0,"1",sys_stream,MANDATORY);
853 return call_primitive(fflush_internal,NARGS(args),args,0);
854 }
855
864 static long get_buffer_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
865 {
866 ptr_stream srm = (ptr_stream)BYTEDATA_DATA(args[0]);
867 /*FILE* fp = *(FILE**)BYTEDATA_DATA(args[0]);*/
868 long size = *(REAL*)args[1]->value_3;
869 ptr_psi_term t = stack_psi_term(4);
870 t->type = quoted_string;
871 t->value_3=(GENERIC)heap_alloc(size+1);
872 bzero((char*)t->value_3,size+1);
873 FP_PREPARE(srm,FP_INPUT);
874 if (fread((void*)t->value_3,sizeof(char),size,srm->fp) <= 0)
875 return FALSE;
876 push_goal(unify,t,result,NULL);
877 return TRUE;
878 }
879
885 static long c_get_buffer()
886 {
887 psi_arg args[2];
888 SETARG(args,0,"1",sys_stream,REQUIRED);
889 SETARG(args,1,"2",integer,REQUIRED);
890 return call_primitive(get_buffer_internal,NARGS(args),args,0);
891 }
892
893
907 int text_buffer_next(struct text_buffer *buf,int idx,char c,struct text_buffer **rbuf,int *ridx)
908 {
909 while (buf) {
910 while (idx<buf->top)
911 if (buf->data[idx] == c) {
912 *rbuf=buf;
913 *ridx=idx;
914 return 1;
915 }
916 else idx++;
917 buf=buf->next;
918 idx=0;
919 }
920 return 0;
921 }
922
934 char *text_buffer_cmp(struct text_buffer *buf,int idx,char *str)
935 {
936 while (buf) {
937 while (idx<buf->top)
938 if (!*str || buf->data[idx] != *str)
939 return 0;
940 else { idx++; str++; }
941 if (!*str && !buf->next) return str;
942 else {
943 buf=buf->next;
944 idx=0;
945 }
946 }
947 return 0;
948 }
949
961 void text_buffer_push(struct text_buffer **buf,char c)
962 {
963 if ((*buf)->top < TEXTBUFSIZE)
964 (*buf)->data[(*buf)->top++] = c;
965 else {
966 (*buf)->next = (struct text_buffer *)
967 malloc(sizeof(struct text_buffer));
968 if (!(*buf)->next) {
969 fprintf(stderr,"Fatal error: malloc failed in text_buffer_push\n");
970 exit(EXIT_FAILURE);
971 }
972 bzero((char*)(*buf)->next,sizeof(struct text_buffer));
973 *buf = (*buf)->next;
974 (*buf)->top = 1;
975 (*buf)->data[0]=c;
976 }
977 }
978
986 void text_buffer_free(struct text_buffer *buf)
987 {
988 struct text_buffer *next;
989 while (buf) {
990 next = buf->next;
991 free(buf);
992 buf=next;
993 }
994 }
995
1004 static long get_record_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
1005 {
1006 struct text_buffer rootbuf;
1007 struct text_buffer *curbuf = &rootbuf;
1008 struct text_buffer *lastbuf = &rootbuf;
1009 int lastidx = 0,size;
1010 ptr_stream srm = (ptr_stream)BYTEDATA_DATA(args[0]);
1011 FILE *fp = srm->fp; /*FILE* fp = *(FILE**)BYTEDATA_DATA(args[0]);*/
1012 char *sep = (char*)args[1]->value_3;
1013 int c;
1014 ptr_psi_term t;
1015 char *cursep = sep;
1016
1017 FP_PREPARE(srm,FP_INPUT);
1018 bzero((char*)&rootbuf,sizeof(rootbuf));
1019 if (!sep || !*sep) {
1020 /* no separator: just grab as much as you can */
1021 while ((c=getc(fp)) != EOF)
1022 text_buffer_push(&curbuf,(char)c);
1023 goto PackUpAndLeave;
1024 }
1025
1026 if (sep[1]=='\0') {
1027 /* only one char in string */
1028 while ((c=getc(fp)) != EOF) {
1029 text_buffer_push(&curbuf,(char)c);
1030 if (c==*sep) break;
1031 }
1032 goto PackUpAndLeave;
1033 }
1034
1035 /* general case: multicharacter separator */
1036
1037 WaitForStart:
1038 if ((c=getc(fp)) == EOF) goto PackUpAndLeave;
1039 text_buffer_push(&curbuf,(char)c);
1040 if (c==*sep) {
1041 cursep = sep+1;
1042 lastbuf=curbuf;
1043 lastidx=curbuf->top - 1;
1044 goto MatchNext;
1045 }
1046 else goto WaitForStart;
1047
1048 MatchNext:
1049 if (!*cursep || (c=getc(fp))==EOF) goto PackUpAndLeave;
1050 text_buffer_push(&curbuf,(char)c);
1051 if (c!=*cursep) goto TryAgain;
1052 cursep++;
1053 goto MatchNext;
1054
1055 TryAgain:
1056 if (!text_buffer_next(lastbuf,lastidx+1,*sep,&lastbuf,&lastidx))
1057 goto WaitForStart;
1058 if (!(cursep=text_buffer_cmp(lastbuf,lastidx,sep)))
1059 goto TryAgain;
1060 goto MatchNext;
1061
1062 PackUpAndLeave:
1063 /* compute how much space we need */
1064 for(lastbuf=&rootbuf,size=0;lastbuf!=NULL;lastbuf=lastbuf->next)
1065 size += lastbuf->top;
1066 t=stack_psi_term(0);
1067 t->type=quoted_string;
1068 t->value_3=(GENERIC)heap_alloc(size+1);
1069 for(lastbuf=&rootbuf,sep=(char*)t->value_3;
1070 lastbuf!=NULL;sep+=lastbuf->top,lastbuf=lastbuf->next)
1071 bcopy(lastbuf->data,sep,lastbuf->top);
1072 ((char*)t->value_3)[size]='\0';
1073 text_buffer_free(rootbuf.next);
1074 push_goal(unify,t,result,NULL);
1075 return TRUE;
1076 }
1077
1083 static long c_get_record()
1084 {
1085 psi_arg args[2];
1086 SETARG(args,0,"1",sys_stream,REQUIRED);
1087 SETARG(args,1,"2",quoted_string,REQUIRED);
1088 return call_primitive(get_record_internal,NARGS(args),args,0);
1089 }
1090
1099 static long get_code_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
1100 {
1101 ptr_stream srm = (ptr_stream)BYTEDATA_DATA(args[0]);
1102 int c;
1103 FP_PREPARE(srm,FP_INPUT);
1104 if ((c=getc(srm->fp)) == EOF) return FALSE;
1105 else return unify_real_result(result,(REAL)c);
1106 }
1107
1113 static long c_get_code()
1114 {
1115 psi_arg args[1];
1116 SETARG(args,0,"1",sys_stream,REQUIRED);
1117 return call_primitive(get_code_internal,NARGS(args),args,0);
1118 }
1119
1128 static long ftell_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
1129 {
1130 ptr_stream srm = (ptr_stream)BYTEDATA_DATA(args[0]);
1131 if (srm->op != FP_NONE || srm->op != FP_INPUT) {
1132 fflush(srm->fp);
1133 srm->op = FP_NONE;
1134 }
1135 return unify_real_result(result,(REAL)ftell(srm->fp));
1136 /* *(FILE**)BYTEDATA_DATA(args[0])));*/
1137 }
1138
1144 static long c_ftell()
1145 {
1146 psi_arg args[1];
1147 SETARG(args,0,"1",sys_file_stream,REQUIRED);
1148 return call_primitive(ftell_internal,NARGS(args),args,0);
1149 }
1150
1151 #ifndef SEEK_SET
1152 #define SEEK_SET 0
1153 #endif
1154 #ifndef SEEK_CUR
1155 #define SEEK_CUR 1
1156 #endif
1157 #ifndef SEEK_END
1158 #define SEEK_END 2
1159 #endif
1160
1169 static long fseek_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
1170 {
1171 ptr_stream srm = (ptr_stream)BYTEDATA_DATA(args[0]);
1172 srm->op = FP_NONE;
1173 return
1174 (fseek(srm->fp ,
1175 (long)*(REAL*)args[1]->value_3,
1176 args[2]?(long)*(REAL*)args[2]->value_3:SEEK_SET) < 0)
1177 ?FALSE:TRUE;
1178 }
1179
1185 static long c_fseek()
1186 {
1187 psi_arg args[3];
1188 SETARG(args,0,"1",sys_file_stream,MANDATORY);
1189 SETARG(args,1,"2",integer,MANDATORY);
1190 SETARG(args,2,"3",integer,OPTIONAL);
1191 return call_primitive(fseek_internal,NARGS(args),args,0);
1192 }
1193
1202 static long stream2sys_stream_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
1203 {
1204 push_goal(unify,fileptr2stream((FILE*)args[0]->value_3,sys_stream),
1205 result,NULL); // added & DJD
1206 return TRUE;
1207 }
1208
1214 static long c_stream2sys_stream()
1215 {
1216 psi_arg args[1];
1217 SETARG(args,0,"1",stream,REQUIRED);
1218 return call_primitive(stream2sys_stream_internal,NARGS(args),args,0);
1219 }
1220
1229 static long sys_stream2stream_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
1230 {
1231 ptr_psi_term tmp;
1232 tmp=stack_psi_term(4);
1233 tmp->type=stream;
1234 tmp->value_3=(GENERIC)((ptr_stream)BYTEDATA_DATA(args[0]))->fp;
1235 push_goal(unify,tmp,result,NULL);
1236 return TRUE;
1237 }
1238
1244 static long c_sys_stream2stream()
1245 {
1246 psi_arg args[1];
1247 SETARG(args,0,"1",sys_stream,REQUIRED);
1248 return call_primitive(sys_stream2stream_internal,NARGS(args),args,0);
1249 }
1250
1251 /* SOCKETS AND NETWORKING *
1252 **************************/
1253
1254 #include <sys/socket.h>
1255 #include <netinet/in.h>
1256 #include <sys/un.h>
1257 #include <netdb.h>
1258 #include <arpa/inet.h>
1259 #include <ctype.h>
1260
1269 static long socket_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
1270 {
1271 int addr_family=AF_INET,type=SOCK_STREAM,protocol=0;
1272 char *s;
1273 int fd;
1274
1275 if (args[0]) {
1276 s=(char*)args[0]->value_3;
1277 if (!strcmp(s,"AF_UNIX")) addr_family=AF_UNIX;
1278 else if (!strcmp(s,"AF_INET")) addr_family=AF_INET;
1279 else {
1280 Errorline("Unknown address family in %P.\n",funct);
1281 return FALSE; }
1282 }
1283
1284 if (args[1]) {
1285 s=(char*)args[1]->value_3;
1286 if (!strcmp(s,"SOCK_STREAM")) type=SOCK_STREAM;
1287 else if (!strcmp(s,"SOCK_DGRAM" )) type=SOCK_DGRAM;
1288 else if (!strcmp(s,"SOCK_RAW" )) {
1289 Errorline("SOCK_RAW not supported in %P.\n",funct);
1290 return FALSE; }
1291 else {
1292 Errorline("Unknown socket type in %P.\n",funct);
1293 return FALSE; }
1294 }
1295
1296 if ((fd=socket(addr_family,type,protocol))<0)
1297 return FALSE;
1298
1299 { FILE*fp = fdopen(fd,"r+");
1300 // ptr_psi_term t;
1301
1302 if (fp==NULL) {
1303 Errorline("fdopen failed on socket in %P.\n",funct);
1304 return FALSE;
1305 }
1306
1307 /* t = make_bytedata(sys_socket_stream,sizeof(fp));
1308 *(FILE**)BYTEDATA_DATA(t) = fp;*/
1309 push_goal(unify,fileptr2stream(fp,sys_socket_stream),result,NULL); // added & DJD
1310 }
1311 return TRUE;
1312 }
1313
1319 static long c_socket()
1320 {
1321 psi_arg args[2];
1322 SETARG(args,0,"1",quoted_string,OPTIONAL);
1323 SETARG(args,1,"2",quoted_string,OPTIONAL);
1324 return call_primitive(socket_internal,NARGS(args),args,0);
1325 }
1326
1333 int is_ipaddr(char *s)
1334 {
1335 if (s==NULL) return 0;
1336 while (*s)
1337 if (!isdigit(*s) && *s!='.') return 0;
1338 else s++;
1339 return 1;
1340 }
1341
1351 static long bind_or_connect_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct,void *info)
1352 {
1353 int fd = fileno(((ptr_stream)BYTEDATA_DATA(args[0]))->fp);
1354 int do_bind = info==NULL;
1355
1356 if (args[1] || args[2]) {
1357 /* bind or connect in the internet domain */
1358 struct sockaddr_in name_loc;
1359 char* hostname = args[1]?(char*)args[1]->value_3:NULL;
1360 if (!args[2]) {
1361 Errorline("Missing port number in %P.\n",funct);
1362 return FALSE;
1363 }
1364
1365 bzero((char*)&name_loc,sizeof(name_loc));
1366 name_loc.sin_family = AF_INET;
1367 name_loc.sin_port = htons((unsigned short)*(REAL*)args[2]->value_3);
1368
1369 if (!hostname || *hostname=='\0' || !strcasecmp(hostname,"localhost"))
1370 name_loc.sin_addr.s_addr = INADDR_ANY;
1371 else {
1372 struct hostent * h;
1373 int ipaddr;
1374 if ((ipaddr=is_ipaddr(hostname))) {
1375 int i = inet_addr(hostname);
1376 h = gethostbyaddr((char*)&i,sizeof(i),AF_INET);
1377 } else h = gethostbyname(hostname);
1378 if (h==NULL) {
1379 Errorline("%s failed for %P.\n",
1380 ipaddr?"gethostbyaddr":"gethostbyname",funct);
1381 return FALSE;
1382 }
1383 bcopy(h->h_addr,(char*)&(name_loc.sin_addr.s_addr),h->h_length);
1384 }
1385 if ((do_bind?
1386 bind(fd,(struct sockaddr *)&name_loc,sizeof(name_loc)):
1387 connect(fd,(struct sockaddr *)&name_loc,sizeof(name_loc))) < 0) {
1388 Errorline("%s failed in %P.\n",do_bind?"bind":"connect",funct);
1389 return FALSE;
1390 }
1391 }
1392 else if (args[3]) {
1393 /* bind in the unix domain */
1394 struct sockaddr_un name_loc;
1395 char* path = (char*)args[3]->value_3;
1396
1397 name_loc.sun_family = AF_UNIX;
1398 strcpy(name_loc.sun_path,path);
1399
1400 if ((do_bind?
1401 bind(fd,(struct sockaddr *)&name_loc,sizeof(name_loc)):
1402 connect(fd,(struct sockaddr *)&name_loc,sizeof(name_loc))) < 0) {
1403 Errorline("%s failed in %P.\n",do_bind?"bind":"connect",funct);
1404 return FALSE;
1405 }
1406 }
1407 else {
1408 Errorline("Too few arguments in %P.\n",funct);
1409 return FALSE;
1410 }
1411 return TRUE;
1412 }
1413
1419 static long c_bind()
1420 {
1421 psi_arg args[4];
1422 SETARG(args,0,"1",sys_socket_stream,MANDATORY);
1423 SETARG(args,1,"host",quoted_string,OPTIONAL);
1424 SETARG(args,2,"port",integer,OPTIONAL);
1425 SETARG(args,3,"path",quoted_string,OPTIONAL);
1426 return call_primitive(bind_or_connect_internal,NARGS(args),args,NULL);
1427 }
1428
1434 static long c_connect()
1435 {
1436 psi_arg args[4];
1437 SETARG(args,0,"1",sys_socket_stream,MANDATORY);
1438 SETARG(args,1,"host",quoted_string,OPTIONAL);
1439 SETARG(args,2,"port",integer,OPTIONAL);
1440 SETARG(args,3,"path",quoted_string,OPTIONAL);
1441 return call_primitive(bind_or_connect_internal,NARGS(args),args,(GENERIC)1);
1442 }
1443
1444 static long
1445 listen_internal(args,result,funct)
1446 ptr_psi_term args[],result,funct;
1447 {
1448 int fd = fileno(((ptr_stream)BYTEDATA_DATA(args[0]))->fp);
1449 int n = *(REAL*)args[1]->value_3;
1450
1451 if (listen(fd,n) < 0) return FALSE;
1452 return TRUE;
1453 }
1454
1460 static long c_listen()
1461 {
1462 psi_arg args[2];
1463 SETARG(args,0,"1",sys_socket_stream,MANDATORY);
1464 SETARG(args,1,"2",integer,MANDATORY);
1465 return call_primitive(listen_internal,NARGS(args),args,0);
1466 }
1467
1476 static long accept_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
1477 {
1478 int fd = fileno(((ptr_stream)BYTEDATA_DATA(args[0]))->fp);
1479 int s;
1480
1481 if ((s=accept(fd,NULL,NULL)) < 0) return FALSE;
1482 else {
1483 FILE * fp = fdopen(s,"r+");
1484 // ptr_psi_term t;
1485
1486 if (fp==NULL) {
1487 Errorline("fdopen failed on socket in %P.\n",funct);
1488 return FALSE;
1489 }
1490
1491 /* t = make_bytedata(sys_socket_stream,sizeof(fp));
1492 *(FILE**)BYTEDATA_DATA(t) = fp;*/
1493 push_goal(unify,fileptr2stream(fp,sys_socket_stream),result,NULL); // added & DJD
1494 return TRUE;
1495 }
1496 }
1497
1503 static long c_accept()
1504 {
1505 psi_arg args[1];
1506 SETARG(args,0,"1",sys_socket_stream,REQUIRED);
1507 return call_primitive(accept_internal,NARGS(args),args,0);
1508 }
1509
1510 /* SYSTEM ERRORS *
1511 *****************/
1512
1521 static long errno_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
1522 {
1523 push_goal(unify,stack_int(errno),result,NULL);
1524 return TRUE;
1525 }
1526
1532 static long c_errno()
1533 {
1534 return call_primitive(errno_internal,0,NULL,0);
1535 }
1536
1537 /* some systems are missing these declarations */
1538 // extern char *sys_errlist[];
1539 // extern int sys_nerr;
1540
1549 static long errmsg_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
1550 {
1551 long n = args[0]?(long)*(REAL*)args[0]->value_3:errno;
1552 // if (n<0 || n>=sys_nerr) return FALSE;
1553 // else {
1554 push_goal(unify,stack_string(strerror(n)),result,NULL);
1555 return TRUE;
1556 // }
1557 }
1558
1564 static long c_errmsg()
1565 {
1566 psi_arg args[1];
1567 SETARG(args,0, "1" , integer , OPTIONAL );
1568 return call_primitive(errmsg_internal,NARGS(args),args,0);
1569 }
1570
1571 /* MODULES *
1572 ***********/
1573
1582 static long import_symbol_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
1583 {
1584 ptr_keyword key;
1585
1586 if (args[1])
1587 key=args[1]->type->keyword;
1588 else
1589 key=hash_lookup(current_module->symbol_table,
1590 args[0]->type->keyword->symbol);
1591
1592 if (key)
1593 if (key->definition->type_def != (def_type)undef_it) {
1594 Errorline("symbol %s already defined in %P.",key->combined_name,funct);
1595 return FALSE;
1596 }
1597 else key->definition=args[0]->type;
1598 else {
1599 /* adapted from update_symbol in modules.c */
1600 /* Add 'module#symbol' to the symbol table */
1601 key=HEAP_ALLOC(struct wl_keyword);
1602 key->module=current_module;
1603 /* use same name */
1604 key->symbol=args[0]->type->keyword->symbol;
1605 key->combined_name=(char *)
1606 heap_copy_string(make_module_token(current_module,key->symbol));
1607 key->public=FALSE;
1608 key->private_feature=FALSE;
1609 key->definition=args[0]->type; /* use given definition */
1610
1611 hash_insert(current_module->symbol_table,key->symbol,key);
1612 }
1613 return TRUE;
1614 }
1615
1624 static long c_import_symbol()
1625 {
1626 psi_arg args[2];
1627 SETARG(args,0,"1",top,MANDATORY|UNEVALED);
1628 SETARG(args,1,"as",top,OPTIONAL|NOVALUE|UNEVALED);
1629 return call_primitive(import_symbol_internal,NARGS(args),args,0);
1630 }
1631
1632 /* PROCESSES *
1633 *************/
1634
1643 static long fork_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
1644 {
1645 pid_t id = fork();
1646 if (id < 0) return FALSE;
1647 else return unify_real_result(result,(REAL)id);
1648 }
1649
1655 static long c_fork()
1656 {
1657 return call_primitive(fork_internal,0,NULL,0);
1658 }
1659
1660 typedef struct {
1661 char * name_str;
1662 ptr_psi_term value_str;
1663 } psi_feature;
1664
1665 #define SETFEATURE(lst,n,nam,val) ((lst[n].name_str=nam),(lst[n].value_str=val))
1666
1676 static long unify_pterm_result(ptr_psi_term t,ptr_definition sym,psi_feature lst[],int n)
1677 {
1678 ptr_psi_term u;
1679 int i;
1680 if (n<0) {
1681 fprintf(stderr,"unify_pterm_result called with n<0: n=%d\n",n);
1682 exit(EXIT_FAILURE);
1683 }
1684 u=stack_psi_term(4);
1685 u->type=sym;
1686 for(i=0;i<n;i++)
1687 (void)stack_insert(FEATCMP,lst[i].name_str,&(u->attr_list),(GENERIC)lst[i].value_str);
1688 push_goal(unify,t,u,NULL);
1689 return TRUE;
1690 }
1691
1698 char *get_numeric_feature(long n)
1699 {
1700 if (n==1) return one;
1701 else if (n==2) return two;
1702 else if (n==3) return three;
1703 else {
1704 char buf[100];
1705 (void)snprintf(buf,100,"%ld",n);
1706 return heap_copy_string(buf);
1707 }
1708 }
1709
1710 #ifndef WIFEXITED
1711 #include <sys/wait.h>
1712 #endif
1713
1722 static long unify_wait_result(ptr_psi_term result,pid_t id,int status)
1723 {
1724 int n=2;
1725 long status2;
1726 ptr_definition sym;
1727 psi_feature lst[2];
1728 SETFEATURE(lst,0,one,stack_int(id));
1729 if (id == -1 || status == -1) {
1730 if (errno==ECHILD) {
1731 sym = sys_process_no_children;
1732 n=0;
1733 }
1734 else return FALSE;
1735 }
1736 else if (WIFEXITED(status)) {
1737 SETFEATURE(lst,1,two,stack_int(WEXITSTATUS(status)));
1738 sym = sys_process_exited;
1739 }
1740 else if (WIFSIGNALED(status)) {
1741 SETFEATURE(lst,1,two,stack_int(WTERMSIG(status)));
1742 sym = sys_process_signaled;
1743 }
1744 else if (WIFSTOPPED(status)) {
1745 SETFEATURE(lst,1,two,stack_int(WSTOPSIG(status)));
1746 sym = sys_process_stopped;
1747 }
1748 #ifdef WIFCONTINUED
1749 else if (WIFCONTINUED(status)) {
1750 sym = sys_process_continued;
1751 n=1;
1752 }
1753 #endif
1754 else {
1755 status2 = status;
1756 Errorline("Unexpected wait status: %d",status2);
1757 return FALSE;
1758 }
1759 return unify_pterm_result(result,sym,lst,n);
1760 }
1761
1770 static long wait_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
1771 {
1772 int status;
1773 pid_t id = wait(&status);
1774 return unify_wait_result(result,id,status);
1775 }
1776
1782 static long c_wait()
1783 {
1784 return call_primitive(wait_internal,0,NULL,0);
1785 }
1786
1795 static long waitpid_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
1796 {
1797 int status;
1798 pid_t id = waitpid((pid_t)(long)*(REAL*)args[0]->value_3,&status,
1799 args[1]?(int)(long)*(REAL*)args[1]->value_3:0);
1800 return unify_wait_result(result,id,status);
1801 }
1802
1808 static long c_waitpid()
1809 {
1810 psi_arg args[2];
1811 SETARG(args,0,"1",integer,REQUIRED);
1812 SETARG(args,1,"2",integer,OPTIONAL);
1813 return call_primitive(waitpid_internal,NARGS(args),args,0);
1814 }
1815
1824 static long kill_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
1825 {
1826 return (kill((pid_t)*(REAL*)args[0]->value_3,
1827 (int)*(REAL*)args[1]->value_3)==0)?TRUE:FALSE;
1828 }
1829
1835 static long c_kill()
1836 {
1837 psi_arg args[2];
1838 SETARG(args,0,"1",integer,MANDATORY);
1839 SETARG(args,1,"2",integer,MANDATORY);
1840 return call_primitive(kill_internal,NARGS(args),args,0);
1841 }
1842
1843 /* MISCELLANEOUS *
1844 ****************/
1845
1854 static long cuserid_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
1855 {
1856 // char name[L_cuserid+1];
1857 // if (*cuserid(name) == '\0') return FALSE;
1858 // else {
1859 push_goal(unify,result,stack_string(getlogin()),NULL);
1860 return TRUE;
1861 // }
1862 }
1863
1869 static long c_cuserid()
1870 {
1871 return call_primitive(cuserid_internal,0,NULL,0);
1872 }
1873
1874 #ifndef MAXHOSTNAMELEN
1875 #include <sys/param.h>
1876 #endif
1877
1886 static long gethostname_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
1887 {
1888 char name_loc[MAXHOSTNAMELEN+1];
1889 if (gethostname(name_loc,MAXHOSTNAMELEN+1) == 0) {
1890 push_goal(unify,result,stack_string(name_loc),NULL);
1891 return TRUE;
1892 }
1893 else return FALSE;
1894 }
1895
1901 static long c_gethostname()
1902 {
1903 return call_primitive(gethostname_internal,0,NULL,0);
1904 }
1905
1906 /* LAZY PROJECT
1907 ***************/
1908
1917 static long lazy_project_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
1918 {
1919 ptr_node n;
1920 char buffer_loc[100];
1921 if (args[1]->type == top) {
1922 residuate(args[0]);
1923 residuate(args[1]);
1924 return TRUE;
1925 }
1926 if (sub_type(args[1]->type,integer) && args[1]->value_3)
1927 snprintf(buffer_loc,100,"%ld",(long)*(REAL*)args[1]->value_3);
1928 else if (sub_type(args[1]->type,quoted_string) && args[1]->value_3)
1929 strcpy(buffer_loc,(char*)args[1]->value_3);
1930 else
1931 strcpy(buffer_loc,args[1]->type->keyword->symbol);
1932 n=find(FEATCMP,buffer_loc,args[0]->attr_list);
1933 if (n) push_goal(unify,(ptr_psi_term)n->data,result,NULL);
1934 /* this is all bullshit because projection should residuate
1935 on its 2nd arg until it becomes value. In particular, think
1936 of using `int' as a feature when it is clear that `int' may
1937 subsequently be refined to a particular integer. */
1938 else residuate(args[0]);
1939 return TRUE;
1940 }
1941
1947 static long c_lazy_project()
1948 {
1949 psi_arg args[2];
1950 SETARG(args,0,"1",top,REQUIRED|NOVALUE);
1951 SETARG(args,1,"2",top,REQUIRED|NOVALUE);
1952 return call_primitive(lazy_project_internal,NARGS(args),args,0);
1953 }
1954
1955 /* WAIT_ON_FEATURE
1956 ******************/
1957
1966 static long wait_on_feature_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
1967 {
1968 char buffer_loc[100];
1969 if (args[1]->type == top) {
1970 residuate(args[0]);
1971 residuate(args[1]);
1972 return TRUE;
1973 }
1974 if (sub_type(args[1]->type,integer) && args[1]->value_3)
1975 snprintf(buffer_loc,100,"%ld",(long)*(REAL*)args[1]->value_3);
1976 else if (sub_type(args[1]->type,quoted_string) && args[1]->value_3)
1977 strcpy(buffer_loc,(char*)args[1]->value_3);
1978 else
1979 strcpy(buffer_loc,args[1]->type->keyword->symbol);
1980 if (find(FEATCMP,buffer_loc,args[0]->attr_list))
1981 push_goal(prove,args[2],(ptr_psi_term)DEFRULES,NULL);
1982 /* this is all bullshit because projection should residuate
1983 on its 2nd arg until it becomes value. In particular, think
1984 of using `int' as a feature when it is clear that `int' may
1985 subsequently be refined to a particular integer. */
1986 else residuate(args[0]);
1987 return TRUE;
1988 }
1989
1995 static long c_wait_on_feature()
1996 {
1997 psi_arg args[3];
1998 SETARG(args,0,"1",top,MANDATORY|NOVALUE);
1999 SETARG(args,1,"2",top,MANDATORY|NOVALUE);
2000 SETARG(args,2,"3",top,MANDATORY|NOVALUE|UNEVALED);
2001 return call_primitive(wait_on_feature_internal,NARGS(args),args,0);
2002 }
2003
2012 static long my_wait_on_feature_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
2013 {
2014 char buffer_loc[100];
2015 if (args[1]->type == top) {
2016 residuate(args[0]);
2017 residuate(args[1]);
2018 return TRUE;
2019 }
2020 if (sub_type(args[1]->type,integer) && args[1]->value_3)
2021 snprintf(buffer_loc,100,"%ld",(long)*(REAL*)args[1]->value_3);
2022 else if (sub_type(args[1]->type,quoted_string) && args[1]->value_3)
2023 strcpy(buffer_loc,(char*)args[1]->value_3);
2024 else
2025 strcpy(buffer_loc,args[1]->type->keyword->symbol);
2026 if (find(FEATCMP,buffer_loc,args[0]->attr_list)) {
2027 unify_bool_result(result,TRUE);
2028 push_goal(prove,args[2],(ptr_psi_term)DEFRULES,NULL);
2029 }
2030 /* this is all bullshit because projection should residuate
2031 on its 2nd arg until it becomes value. In particular, think
2032 of using `int' as a feature when it is clear that `int' may
2033 subsequently be refined to a particular integer. */
2034 else residuate(args[0]);
2035 return TRUE;
2036 }
2037
2043 static long c_my_wait_on_feature()
2044 {
2045 psi_arg args[3];
2046 SETARG(args,0,"1",top,MANDATORY|NOVALUE);
2047 SETARG(args,1,"2",top,MANDATORY|NOVALUE);
2048 SETARG(args,2,"3",top,MANDATORY|NOVALUE|UNEVALED);
2049 return call_primitive(my_wait_on_feature_internal,NARGS(args),args,0);
2050 }
2051
2063 static long call_once_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
2064 {
2065 ptr_psi_term value;
2066 ptr_choice_point cutpt = choice_stack;
2067 resid_aim=NULL;
2068 value = stack_psi_term(4);
2069 value->type = lf_false;
2070 push_choice_point(unify,result,value,NULL);
2071 value = stack_psi_term(4);
2072 value->type = lf_true;
2073 push_goal(unify,result,value,NULL);
2074 push_goal(general_cut,(ptr_psi_term)cutpt,NULL,NULL);
2075 push_goal(prove,args[0],(ptr_psi_term)DEFRULES,NULL);
2076 return TRUE;
2077 }
2078
2084 static long c_call_once()
2085 {
2086 psi_arg args[1];
2087 SETARG(args,0,"1",top,MANDATORY|NOVALUE|UNEVALED);
2088 return call_primitive(call_once_internal,NARGS(args),args,0);
2089 }
2090
2099 static long apply1_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
2100 {
2101 long success=TRUE;
2102 if (args[0]->type==top) residuate(args[0]);
2103 else if (args[0]->type->type_def!=(def_type)function_it) {
2104 Errorline("1st arg not a function in %P.\n",funct);
2105 success=FALSE;
2106 }
2107 else {
2108 // char buffer_loc[1000];
2109 char * feat;
2110 ptr_psi_term fun;
2111 if (sub_type(args[1]->type,integer) && args[1]->value_3)
2112 feat = get_numeric_feature((long)*(REAL*)args[1]->value_3);
2113 else if (sub_type(args[1]->type,quoted_string) && args[1]->value_3)
2114 feat = (char *)args[1]->value_3;
2115 else
2116 feat = (char *)heap_copy_string(args[1]->type->keyword->symbol);
2117 clear_copy();
2118 fun=distinct_copy(args[0]);
2119 (void)stack_insert(FEATCMP,(char *)feat,&(fun->attr_list),(GENERIC)args[2]);
2120 push_goal(eval,fun,result,(GENERIC)fun->type->rule);
2121 }
2122 return success;
2123 }
2124
2130 static long c_apply1()
2131 {
2132 psi_arg args[3];
2133 SETARG(args,0,"1",top,REQUIRED|NOVALUE);
2134 SETARG(args,1,"2",top,REQUIRED|NOVALUE);
2135 SETARG(args,2,"3",top,REQUIRED|NOVALUE);
2136 return call_primitive(apply1_internal,NARGS(args),args,0);
2137 }
2138
2147 static long getpid_internal(ptr_psi_term args[],ptr_psi_term result,ptr_psi_term funct)
2148 {
2149 return unify_real_result(result,(REAL)getpid());
2150 }
2151
2157 static long c_getpid()
2158 {
2159 return call_primitive(getpid_internal,0,0,0);
2160 }
2161
2168 void make_sys_type_links()
2169 {
2170 #ifdef LIFE_NDBM
2171 make_ndbm_type_links();
2172 #endif
2173 make_type_link(sys_bitvector ,sys_bytedata);
2174 make_type_link(sys_regexp ,sys_bytedata);
2175 make_type_link(sys_stream ,sys_bytedata);
2176 make_type_link(sys_file_stream ,sys_stream);
2177 make_type_link(sys_socket_stream,sys_stream);
2178 make_type_link(sys_bytedata ,built_in); /* DENYS: BYTEDATA */
2179 }
2180
2186 void check_sys_definitions()
2187 {
2188 check_definition(&sys_bytedata); /* DENYS: BYTEDATA */
2189 check_definition(&sys_bitvector);
2190 check_definition(&sys_regexp);
2191 check_definition(&sys_stream);
2192 check_definition(&sys_file_stream);
2193 check_definition(&sys_socket_stream);
2194 check_definition(&sys_process_no_children);
2195 check_definition(&sys_process_exited);
2196 check_definition(&sys_process_signaled);
2197 check_definition(&sys_process_stopped);
2198 check_definition(&sys_process_continued);
2199 #ifdef LIFE_NDBM
2200 check_ndbm_definitions();
2201 #endif
2202 }
2203
2209 void insert_sys_builtins()
2210 {
2211 ptr_module curmod = current_module;
2212 (void)set_current_module(sys_module);
2213
2214 sys_bytedata =update_symbol(sys_module,"bytedata"); /* DENYS: BYTEDATA */
2215 sys_bitvector =update_symbol(sys_module,"bitvector");
2216 sys_regexp =update_symbol(sys_module,"regexp");
2217 sys_stream =update_symbol(sys_module,"stream");
2218 sys_file_stream =update_symbol(sys_module,"file_stream");
2219 sys_socket_stream =update_symbol(sys_module,"socket_stream");
2220 sys_process_no_children=update_symbol(sys_module,"process_no_children");
2221 sys_process_exited =update_symbol(sys_module,"process_exited");
2222 sys_process_signaled =update_symbol(sys_module,"process_signaled");
2223 sys_process_stopped =update_symbol(sys_module,"process_stopped");
2224 sys_process_continued =update_symbol(sys_module,"process_continued");
2225
2226 /* DENYS: BYTEDATA */
2227 /* purely for illustration
2228 new_built_in(sys_module,"string_to_bytedata",(def_type)function_it,c_string_to_bytedata);
2229 new_built_in(sys_module,"bytedata_to_string",(def_type)function_it,c_bytedata_to_string);
2230 */
2231 new_built_in(sys_module,"make_bitvector" ,(def_type)function_it ,c_make_bitvector);
2232 new_built_in(sys_module,"bitvector_and" ,(def_type)function_it ,c_bitvector_and);
2233 new_built_in(sys_module,"bitvector_or" ,(def_type)function_it ,c_bitvector_or);
2234 new_built_in(sys_module,"bitvector_xor" ,(def_type)function_it ,c_bitvector_xor);
2235 new_built_in(sys_module,"bitvector_not" ,(def_type)function_it ,c_bitvector_not);
2236 new_built_in(sys_module,"bitvector_count" ,(def_type)function_it ,c_bitvector_count);
2237 new_built_in(sys_module,"bitvector_get" ,(def_type)function_it ,c_bitvector_get);
2238 new_built_in(sys_module,"bitvector_set" ,(def_type)function_it ,c_bitvector_set);
2239 new_built_in(sys_module,"bitvector_clear" ,(def_type)function_it ,c_bitvector_clear);
2240 new_built_in(sys_module,"regexp_compile" ,(def_type)function_it ,c_regexp_compile);
2241 new_built_in(sys_module,"regexp_execute" ,(def_type)function_it ,c_regexp_execute);
2242 new_built_in(sys_module,"int2stream" ,(def_type)function_it ,c_int2stream);
2243 new_built_in(sys_module,"fopen" ,(def_type)function_it ,c_fopen);
2244 new_built_in(sys_module,"fclose" ,(def_type)function_it ,c_fclose);
2245 new_built_in(sys_module,"get_buffer" ,(def_type)function_it ,c_get_buffer);
2246 new_built_in(sys_module,"get_record" ,(def_type)function_it ,c_get_record);
2247 new_built_in(sys_module,"get_code" ,(def_type)function_it ,c_get_code);
2248 new_built_in(sys_module,"ftell" ,(def_type)function_it ,c_ftell);
2249 new_built_in(sys_module,"fseek" ,(def_type)predicate_it,c_fseek);
2250 new_built_in(sys_module,"socket" ,(def_type)function_it ,c_socket);
2251 new_built_in(sys_module,"bind" ,(def_type)predicate_it,c_bind);
2252 new_built_in(sys_module,"connect" ,(def_type)predicate_it,c_connect);
2253 new_built_in(sys_module,"fwrite" ,(def_type)predicate_it,c_fwrite);
2254 new_built_in(sys_module,"fflush" ,(def_type)predicate_it,c_fflush);
2255 new_built_in(sys_module,"listen" ,(def_type)predicate_it,c_listen);
2256 new_built_in(sys_module,"accept" ,(def_type)function_it ,c_accept);
2257 new_built_in(sys_module,"errno" ,(def_type)function_it ,c_errno);
2258 new_built_in(sys_module,"errmsg" ,(def_type)function_it ,c_errmsg);
2259 new_built_in(sys_module,"import_symbol" ,(def_type)predicate_it,c_import_symbol);
2260 new_built_in(sys_module,"fork" ,(def_type)function_it ,c_fork);
2261 new_built_in(sys_module,"wait" ,(def_type)function_it ,c_wait);
2262 new_built_in(sys_module,"waitpid" ,(def_type)function_it ,c_waitpid);
2263 new_built_in(sys_module,"kill" ,(def_type)predicate_it,c_kill);
2264 new_built_in(sys_module,"cuserid" ,(def_type)function_it ,c_cuserid);
2265 new_built_in(sys_module,"gethostname" ,(def_type)function_it ,c_gethostname);
2266 new_built_in(sys_module,"lazy_project" ,(def_type)function_it ,c_lazy_project);
2267 new_built_in(sys_module,"wait_on_feature" ,(def_type)predicate_it,c_wait_on_feature);
2268 new_built_in(sys_module,"my_wait_on_feature" ,(def_type)function_it ,c_my_wait_on_feature);
2269 new_built_in(sys_module,"apply1" ,(def_type)function_it ,c_apply1);
2270 new_built_in(sys_module,"getpid" ,(def_type)function_it ,c_getpid);
2271 new_built_in(sys_module,"stream2sys_stream" ,(def_type)function_it ,c_stream2sys_stream);
2272 new_built_in(sys_module,"sys_stream2stream" ,(def_type)function_it ,c_sys_stream2stream);
2273 #ifdef LIFE_DBM
2274 insert_dbm_builtins();
2275 #endif
2276 #ifdef LIFE_NDBM
2277 insert_ndbm_builtins();
2278 #endif
2279 (void)set_current_module(bi_module);
2280 new_built_in(bi_module ,"call_once" ,(def_type)function_it ,c_call_once);
2281 (void)set_current_module(curmod);
2282 }
BV_OR
#define BV_OR
Definition: sys.c:182
prove
#define prove
was enum (goal) – but must be long for error.c - now typedef
Definition: def_const.h:1051
new_built_in
void new_built_in(ptr_module m, char *s, def_type t, long(*r)())
new_built_in
Definition: built_ins.c:5375
text_buffer_cmp
char * text_buffer_cmp(struct text_buffer *buf, int idx, char *str)
text_buffer_cmp
Definition: sys.c:934
wl_goal::aaaa_1
ptr_psi_term aaaa_1
Definition: def_struct.h:239
sys_stream
ptr_definition sys_stream
symbol in sys module
Definition: def_glob.h:585
hash_lookup
ptr_keyword hash_lookup(ptr_hash_table table, char *symbol)
HASH_LOOKUP.
Definition: hash_table.c:131
insert_sys_builtins
void insert_sys_builtins()
insert_sys_builtins
Definition: sys.c:2209
BV_NOT
#define BV_NOT
Definition: sys.c:286
function_it
#define function_it
was enum (def_type) in extern.h now there is typedef ptr_definition
Definition: def_const.h:1408
undef_it
#define undef_it
was enum (def_type) in extern.h now there is typedef ptr_definition
Definition: def_const.h:1394
errmsg_internal
static long errmsg_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
errmsg_internal
Definition: sys.c:1549
c_make_bitvector
static long c_make_bitvector()
c_make_bitvector
Definition: sys.c:174
c_bitvector_not
static long c_bitvector_not()
c_bitvector_not
Definition: sys.c:366
c_wait
static long c_wait()
c_wait
Definition: sys.c:1782
MANDATORY
#define MANDATORY
for call_primitive
Definition: def_const.h:818
make_sys_type_links
void make_sys_type_links()
make_sys_type_links
Definition: sys.c:2168
BV_CLEAR
#define BV_CLEAR
Definition: sys.c:383
FEATCMP
#define FEATCMP
indicates to use featcmp for comparison (in trees.c)
Definition: def_const.h:979
clear_copy
void clear_copy()
clear_copy
Definition: copy.c:53
fflush_internal
static long fflush_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
fflush_internal
Definition: sys.c:835
accept_internal
static long accept_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
accept_internal
Definition: sys.c:1476
residuate
void residuate(ptr_psi_term t)
residuate
Definition: lefun.c:125
lf_false
ptr_definition lf_false
symbol in bi module
Definition: def_glob.h:284
integer
ptr_definition integer
symbol in bi module
Definition: def_glob.h:312
wl_choice_point
Definition: def_struct.h:246
call_primitive
long call_primitive(long(*fun)(), int num, psi_arg argi[], GENERIC info)
call_primitive
Definition: sys.c:24
wl_keyword::combined_name
char * combined_name
Definition: def_struct.h:119
text_buffer::data
char data[TEXTBUFSIZE]
Definition: def_struct.h:401
regerror
void regerror(char *s)
regerror
Definition: sys.c:498
fwrite_internal
static long fwrite_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
fwrite_internal
Definition: sys.c:802
bitvector_bit_code
static long bitvector_bit_code(unsigned long *bv1, long idx, ptr_psi_term result, int op, ptr_psi_term funct)
bitvector_bit_code
Definition: sys.c:395
c_accept
static long c_accept()
c_accept
Definition: sys.c:1503
SETARG
#define SETARG(args, i, the_feature, the_type, the_options)
Definition: def_macro.h:168
push_choice_point
void push_choice_point(goals t, ptr_psi_term a, ptr_psi_term b, GENERIC c)
push_choice_point
Definition: login.c:638
push_goal
void push_goal(goals t, ptr_psi_term a, ptr_psi_term b, GENERIC c)
push_goal
Definition: login.c:600
regexp_execute_internal
static long regexp_execute_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
regexp_execute_internal
Definition: sys.c:576
c_fwrite
static long c_fwrite()
c_fwrite
Definition: sys.c:819
bitvector_unop
static long bitvector_unop(GENERIC op)
bitvector_unop
Definition: sys.c:354
text_buffer_free
void text_buffer_free(struct text_buffer *buf)
text_buffer_free
Definition: sys.c:986
c_call_once
static long c_call_once()
c_call_once
Definition: sys.c:2084
unify_bool_result
void unify_bool_result(ptr_psi_term t, long v)
unify_bool_result
Definition: built_ins.c:344
current_module
ptr_module current_module
The current module for the tokenizer.
Definition: def_glob.h:729
two
char * two
Definition: def_glob.h:892
BV_SET
#define BV_SET
Definition: sys.c:382
c_stream2sys_stream
static long c_stream2sys_stream()
c_stream2sys_stream
Definition: sys.c:1214
c_ftell
static long c_ftell()
c_ftell
Definition: sys.c:1144
bitvector_binop_code
static long bitvector_binop_code(unsigned long *bv1, unsigned long *bv2, ptr_psi_term result, GENERIC op)
bitvector_binop_code
Definition: sys.c:194
getpid_internal
static long getpid_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
getpid_internal
Definition: sys.c:2147
wl_module
Definition: def_struct.h:105
general_cut
#define general_cut
was enum (goal) – but must be long for error.c - now typedef
Definition: def_const.h:1114
c_regexp_compile
static long c_regexp_compile()
c_regexp_compile
Definition: sys.c:554
sys_regexp
ptr_definition sys_regexp
symbol in sys module
Definition: def_glob.h:578
c_int2stream
static long c_int2stream()
c_int2stream
Definition: sys.c:723
wl_keyword::definition
ptr_definition definition
Definition: def_struct.h:122
fork_internal
static long fork_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
Definition: sys.c:1643
sys_process_continued
ptr_definition sys_process_continued
symbol in sys module
Definition: def_glob.h:650
wl_definition::type_def
def_type type_def
Definition: def_struct.h:153
c_kill
static long c_kill()
c_kill
Definition: sys.c:1835
defs.h
includes
text_buffer
Definition: def_struct.h:398
predicate_it
#define predicate_it
was enum (def_type) in extern.h now there is typedef ptr_definition
Definition: def_const.h:1401
wl_psi_term
Definition: def_struct.h:177
fileptr2stream
ptr_psi_term fileptr2stream(FILE *fp, ptr_definition typ)
fileptr2stream
Definition: sys.c:688
BV_XOR
#define BV_XOR
Definition: sys.c:183
c_fseek
static long c_fseek()
c_fseek
Definition: sys.c:1185
DEFRULES
#define DEFRULES
Must be different from NULL, a built-in index, and a pointer Used to indicate that the rules of the d...
Definition: def_const.h:302
sys_bitvector
ptr_definition sys_bitvector
symbol in sys module
Definition: def_glob.h:571
c_get_record
static long c_get_record()
c_get_record
Definition: sys.c:1083
a_stream::fp
FILE * fp
Definition: sys.c:673
c_abort
long c_abort()
c_abort
Definition: built_ins.c:2247
fclose_internal
static long fclose_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
fclose_internal
Definition: sys.c:774
stream
ptr_definition stream
symbol in bi module
Definition: def_glob.h:382
psi_feature::value_str
ptr_psi_term value_str
Definition: sys.c:1662
sys_file_stream
ptr_definition sys_file_stream
symbol in sys module
Definition: def_glob.h:592
wl_module::symbol_table
ptr_hash_table symbol_table
Definition: def_struct.h:110
int2stream_internal
static long int2stream_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
int2stream_internal
Definition: sys.c:704
c_getpid
static long c_getpid()
c_getpid
Definition: sys.c:2157
import_symbol_internal
static long import_symbol_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
import_symbol_internal
Definition: sys.c:1582
c_get_code
static long c_get_code()
c_get_code
Definition: sys.c:1113
wl_definition::keyword
ptr_keyword keyword
Definition: def_struct.h:147
bind_or_connect_internal
static long bind_or_connect_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct, void *info)
bind_or_connect_internal
Definition: sys.c:1351
c_bitvector_set
static long c_bitvector_set()
c_bitvector_set
Definition: sys.c:472
ptr_psi_term
struct wl_psi_term * ptr_psi_term
quotedStackCopy
Definition: def_struct.h:62
c_fclose
static long c_fclose()
c_fclose
Definition: sys.c:787
wl_node::data
GENERIC data
Definition: def_struct.h:201
curry
void curry()
curry
Definition: lefun.c:174
NULL
#define NULL
Definition: def_const.h:533
REAL
#define REAL
Which C type to use to represent reals and integers in Wild_Life.
Definition: def_const.h:132
three
char * three
Definition: def_glob.h:893
wl_keyword::symbol
char * symbol
Definition: def_struct.h:118
resid_aim
ptr_goal resid_aim
Definition: def_glob.h:865
overlap_type
long overlap_type(ptr_definition t1, ptr_definition t2)
overlap_type
Definition: types.c:1579
bitvector_bit
static long bitvector_bit(long op)
bitvector_bit
Definition: sys.c:449
psi_arg
Definition: def_struct.h:363
update_symbol
ptr_definition update_symbol(ptr_module module, char *symbol)
update_symbol
Definition: modules.c:270
psi_feature
Definition: sys.c:1660
call_once_internal
static long call_once_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
call_once_internal
Definition: sys.c:2063
waitpid_internal
static long waitpid_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
waitpid_internal
Definition: sys.c:1795
JUSTFAIL
#define JUSTFAIL
for call_primitive
Definition: def_const.h:725
eval
#define eval
was enum (goal) – but must be long for error.c - now typedef
Definition: def_const.h:1086
built_in
ptr_definition built_in
symbol in bi module
Definition: def_glob.h:199
sys_bytedata
ptr_definition sys_bytedata
symbol in sys module
Definition: def_glob.h:983
FP_OUTPUT
#define FP_OUTPUT
Definition: sys.c:670
c_apply1
static long c_apply1()
c_apply1()
Definition: sys.c:2130
sys_process_no_children
ptr_definition sys_process_no_children
symbol in sys module
Definition: def_glob.h:622
c_bitvector_xor
static long c_bitvector_xor()
c_bitvector_xor
Definition: sys.c:281
sub_type
long sub_type(ptr_definition t1, ptr_definition t2)
sub_type
Definition: types.c:1642
c_fflush
static long c_fflush()
c_fflush
Definition: sys.c:849
make_bitvector_internal
static long make_bitvector_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
make_bitvector_internal
Definition: sys.c:154
c_fopen
static long c_fopen()
c_fopen
Definition: sys.c:758
ptr_stream
struct a_stream * ptr_stream
bitvector_binop
static long bitvector_binop(long op)
bitvector_binop
Definition: sys.c:248
text_buffer::top
int top
Definition: def_struct.h:400
Errorline
void Errorline(char *format,...)
Errorline.
Definition: error.c:465
c_connect
static long c_connect()
c_connect
Definition: sys.c:1434
GENERIC
unsigned long * GENERIC
unsigned long *GENERIC
Definition: def_struct.h:35
get_record_internal
static long get_record_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
get_record_internal
Definition: sys.c:1004
bitvector_binop_internal
static long bitvector_binop_internal(ptr_psi_term *args, ptr_psi_term result, ptr_psi_term funct, GENERIC op)
bitvector_binop_internal
Definition: sys.c:235
unify_wait_result
static long unify_wait_result(ptr_psi_term result, pid_t id, int status)
unify_wait_result
Definition: sys.c:1722
socket_internal
static long socket_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
socket_internal
Definition: sys.c:1269
FP_NONE
#define FP_NONE
Definition: sys.c:668
c_listen
static long c_listen()
c_listen
Definition: sys.c:1460
SETFEATURE
#define SETFEATURE(lst, n, nam, val)
Definition: sys.c:1665
stack_pair
ptr_psi_term stack_pair(ptr_psi_term left, ptr_psi_term right)
stack_pair
Definition: built_ins.c:69
c_import_symbol
static long c_import_symbol()
c_import_symbol
Definition: sys.c:1624
c_waitpid
static long c_waitpid()
c_waitpid
Definition: sys.c:1808
stack_insert
ptr_node stack_insert(long comp, char *keystr, ptr_node *tree, GENERIC info)
stack_insert
Definition: trees.c:337
BV_GET
#define BV_GET
Definition: sys.c:381
deref_ptr
#define deref_ptr(P)
Definition: def_macro.h:100
unify_pterm_result
static long unify_pterm_result(ptr_psi_term t, ptr_definition sym, psi_feature lst[], int n)
unify_pterm_result
Definition: sys.c:1676
BYTEDATA_DATA
#define BYTEDATA_DATA(X)
Definition: sys.c:139
heap_copy_string
char * heap_copy_string(char *s)
heap_copy_string
Definition: trees.c:172
stream2sys_stream_internal
static long stream2sys_stream_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
stream2sys_stream_internal
Definition: sys.c:1202
check_sys_definitions
void check_sys_definitions()
check_sys_definitions
Definition: sys.c:2186
TEXTBUFSIZE
#define TEXTBUFSIZE
Definition: def_struct.h:396
psi_arg::type
ptr_definition type
Definition: def_struct.h:365
REQUIRED
#define REQUIRED
for call_primitive
Definition: def_const.h:631
hash_insert
void hash_insert(ptr_hash_table table, char *symbol, ptr_keyword keyword)
HASH_INSERT.
Definition: hash_table.c:151
distinct_copy
ptr_psi_term distinct_copy(ptr_psi_term t)
distinct_copy
Definition: copy.c:393
TRUE
#define TRUE
Standard boolean.
Definition: def_const.h:268
c_fork
static long c_fork()
c_fork
Definition: sys.c:1655
bitvector_bit_internal
static long bitvector_bit_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct, int op)
bitvector_bit_internal
Definition: sys.c:436
kill_internal
static long kill_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
kill_internal
Definition: sys.c:1824
is_ipaddr
int is_ipaddr(char *s)
is_ipaddr
Definition: sys.c:1333
make_type_link
void make_type_link(ptr_definition t1, ptr_definition t2)
make_type_link
Definition: types.c:901
fseek_internal
static long fseek_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
fseek_internal
Definition: sys.c:1169
stack_int
ptr_psi_term stack_int(long n)
stack_int
Definition: built_ins.c:91
wl_definition::rule
ptr_pair_list rule
Definition: def_struct.h:148
FALSE
#define FALSE
Standard boolean.
Definition: def_const.h:275
deref
#define deref(P)
Definition: def_macro.h:147
sys_stream2stream_internal
static long sys_stream2stream_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
sys_stream2stream_internal
Definition: sys.c:1229
bitvector_unop_code
static long bitvector_unop_code(unsigned long *bv1, ptr_psi_term result, int op)
bitvector_unop_code
Definition: sys.c:297
text_buffer_next
int text_buffer_next(struct text_buffer *buf, int idx, char c, struct text_buffer **rbuf, int *ridx)
text_buffer_next
Definition: sys.c:907
wl_keyword
Definition: def_struct.h:116
get_code_internal
static long get_code_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
get_code_internal
Definition: sys.c:1099
stack_psi_term
ptr_psi_term stack_psi_term(long stat)
stack_psi_term
Definition: lefun.c:21
wl_psi_term::value_3
GENERIC value_3
Definition: def_struct.h:186
BV_AND
#define BV_AND
Definition: sys.c:181
c_bitvector_count
static long c_bitvector_count()
c_bitvector_count
Definition: sys.c:376
aim
ptr_goal aim
Definition: def_glob.h:1024
get_buffer_internal
static long get_buffer_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
get_buffer_internal
Definition: sys.c:864
one
char * one
Definition: def_glob.h:891
insert_dbm_builtins
void insert_dbm_builtins()
c_wait_on_feature
static long c_wait_on_feature()
c_wait_on_feature
Definition: sys.c:1995
FP_INPUT
#define FP_INPUT
Definition: sys.c:669
c_bind
static long c_bind()
c_bind
Definition: sys.c:1419
unify
#define unify
was enum (goal) – but must be long for error.c - now typedef
Definition: def_const.h:1058
regexp_compile_internal
static long regexp_compile_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
regexp_compile_internal
Definition: sys.c:514
ftell_internal
static long ftell_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
ftell_internal
Definition: sys.c:1128
find
ptr_node find(long comp, char *keystr, ptr_node tree)
find
Definition: trees.c:394
c_errno
static long c_errno()
c_errno
Definition: sys.c:1532
a_stream
Definition: sys.c:672
bitvector_unop_internal
static long bitvector_unop_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct, int op)
bitvector_unop_internal
Definition: sys.c:343
fopen_internal
static long fopen_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
fopen_internal
Definition: sys.c:739
wl_definition
Definition: def_struct.h:145
bi_module
ptr_module bi_module
Module for public built-ins.
Definition: def_glob.h:687
get_numeric_feature
char * get_numeric_feature(long n)
get_numeric_feature
Definition: sys.c:1698
c_regexp_execute
static long c_regexp_execute()
c_regexp_execute
Definition: sys.c:648
sys_module
ptr_module sys_module
Definition: def_glob.h:735
c_cuserid
static long c_cuserid()
c_cuserid
Definition: sys.c:1869
wl_keyword::module
ptr_module module
Definition: def_struct.h:117
top
ptr_definition top
symbol in syntax module
Definition: def_glob.h:403
check_definition
void check_definition(ptr_definition *d)
check_definition
Definition: memory.c:663
c_bitvector_or
static long c_bitvector_or()
c_bitvector_or
Definition: sys.c:271
FP_PREPARE
#define FP_PREPARE(s, OP)
Definition: sys.c:677
c_socket
static long c_socket()
c_socket
Definition: sys.c:1319
NOVALUE
#define NOVALUE
for call_primitive
Definition: def_const.h:865
sys_process_signaled
ptr_definition sys_process_signaled
symbol in sys module
Definition: def_glob.h:636
make_module_token
char * make_module_token(ptr_module module, char *str)
make_module_token
Definition: modules.c:191
a_stream::op
int op
Definition: sys.c:674
wait_on_feature_internal
static long wait_on_feature_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
wait_on_feature_internal
Definition: sys.c:1966
SEEK_SET
#define SEEK_SET
Definition: sys.c:1152
unify_real_result
long unify_real_result(ptr_psi_term t, REAL v)
unify_real_result
Definition: built_ins.c:386
c_bitvector_and
static long c_bitvector_and()
c_bitvector_and
Definition: sys.c:261
make_bytedata
static ptr_psi_term make_bytedata(ptr_definition sort, unsigned long bytes)
make_bytedata(
Definition: sys.c:126
NARGS
#define NARGS(args)
Definition: def_macro.h:174
wl_keyword::private_feature
int private_feature
Definition: def_struct.h:121
c_lazy_project
static long c_lazy_project()
c_lazy_project
Definition: sys.c:1947
c_my_wait_on_feature
static long c_my_wait_on_feature()
c_my_wait_on_feature
Definition: sys.c:2043
c_bitvector_get
static long c_bitvector_get()
c_bitvector_get
Definition: sys.c:462
c_bitvector_clear
static long c_bitvector_clear()
c_bitvector_clear
Definition: sys.c:482
psi_feature::name_str
char * name_str
Definition: sys.c:1661
sys_socket_stream
ptr_definition sys_socket_stream
symbol in sys module
Definition: def_glob.h:599
lf_true
ptr_definition lf_true
symbol in bi module
Definition: def_glob.h:410
wl_keyword::public
int public
Definition: def_struct.h:120
wl_node
Definition: def_struct.h:197
wait_internal
static long wait_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
wait_internal
Definition: sys.c:1770
wl_psi_term::type
ptr_definition type
Definition: def_struct.h:181
sys_process_exited
ptr_definition sys_process_exited
symbol in sys module
Definition: def_glob.h:629
wl_goal::bbbb_1
ptr_psi_term bbbb_1
Definition: def_struct.h:240
c_sys_stream2stream
static long c_sys_stream2stream()
c_sys_stream2stream
Definition: sys.c:1244
apply1_internal
static long apply1_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
apply1_internal
Definition: sys.c:2099
stack_string
ptr_psi_term stack_string(char *s)
stack_string
Definition: built_ins.c:109
OPTIONAL
#define OPTIONAL
for call_primitive
Definition: def_const.h:584
listen_internal
static long listen_internal(args, result, funct)
Definition: sys.c:1445
text_buffer::next
struct text_buffer * next
Definition: def_struct.h:399
HEAP_ALLOC
#define HEAP_ALLOC(A)
Definition: def_macro.h:20
errno_internal
static long errno_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
errno_internal
Definition: sys.c:1521
c_gethostname
static long c_gethostname()
c_gethostname
Definition: sys.c:1901
BV_COUNT
#define BV_COUNT
Definition: sys.c:287
wl_psi_term::attr_list
ptr_node attr_list
Definition: def_struct.h:187
my_wait_on_feature_internal
static long my_wait_on_feature_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
my_wait_on_feature_internal
Definition: sys.c:2012
set_current_module
ptr_module set_current_module(ptr_module module)
set_current_module
Definition: modules.c:100
c_get_buffer
static long c_get_buffer()
c_get_buffer
Definition: sys.c:885
ARGNN
#define ARGNN
primitive in sys.c does not allow more than ARGNN (10) arguments
Definition: def_const.h:1387
cuserid_internal
static long cuserid_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
cuserid_internal
Definition: sys.c:1854
quoted_string
ptr_definition quoted_string
symbol in bi module
Definition: def_glob.h:368
gethostname_internal
static long gethostname_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
gethostname_internal
Definition: sys.c:1886
heap_alloc
GENERIC heap_alloc(long s)
heap_alloc
Definition: memory.c:1616
POLYTYPE
#define POLYTYPE
for call_primitive
Definition: def_const.h:772
stack_insert_copystr
void stack_insert_copystr(char *keystr, ptr_node *tree, GENERIC info)
stack_insert_copystr
Definition: trees.c:301
choice_stack
ptr_choice_point choice_stack
Definition: def_glob.h:1026
c_errmsg
static long c_errmsg()
c_errmsg
Definition: sys.c:1564
sys_process_stopped
ptr_definition sys_process_stopped
symbol in sys module
Definition: def_glob.h:643
lazy_project_internal
static long lazy_project_internal(ptr_psi_term args[], ptr_psi_term result, ptr_psi_term funct)
lazy_project_internal
Definition: sys.c:1917
UNEVALED
#define UNEVALED
for call_primitive
Definition: def_const.h:678
text_buffer_push
void text_buffer_push(struct text_buffer **buf, char c)
text_buffer_push
Definition: sys.c:961