Wild Life: sys.c Source File

Wild Life 2.29

- 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 /* Copyright by Denys Duchier, Dec 1994
2 Simon Fraser University
3
4 All new system utilities and extensions to Wild LIFE 1.01
5 are implemented in this file and made available in LIFE
6 module "sys"
7 */
8 /* $Id: sys.c,v 1.9 1996/01/17 00:33:09 duchier Exp $ */
9
10 #include "defs.h"
11
12 long call_primitive(fun,num,argi,info)
13 long (*fun)();
14 int num;
15 psi_arg argi[];
16 GENERIC info;
17 {
18 ptr_psi_term funct,arg,result,argo[ARGNN]; /* no more than 10 arguments */
19 ptr_node n;
20 int allargs=1,allvalues=1,i;
21 funct=aim->aaaa_1;
22 deref_ptr(funct);
23 result=aim->bbbb_1;
24 for (i=0;i<num;i++) {
25 n=find(FEATCMP,argi[i].feature,funct->attr_list);
26 /* argument present */
27 if (n) {
28 arg = (ptr_psi_term) n->data;
29 /* in case we don't want to evaluate the argument
30 just follow the chain of corefs and don't do
31 any of the other checks: they'll have do be done
32 by fun; just go on to the next arg */
33 if (argi[i].options&UNEVALED) {
34 deref_ptr(arg);
35 argo[i]=arg;
36 continue; }
37 /* this arg should be evaled */
38 deref(arg);
39 argo[i]=arg;
40 /* arg of admissible type */
41 if (argi[i].options&POLYTYPE) {
42 ptr_definition *type = (ptr_definition *)argi[i].type;
43 while (*type != NULL)
44 if (overlap_type(arg->type,*type))
45 goto admissible;
46 else type++;
47 }
48 else {
49 if (overlap_type(arg->type,argi[i].type))
50 goto admissible;
51 }
52 /* not admissible */
53 if (argi[i].options&JUSTFAIL) return FALSE;
54 Errorline("Illegal argument in %P.\n",funct);
55 return (c_abort());
56 /* admissible */
57 admissible:
58 /* has value */
59 if (arg->value_3) {
60 ptr_definition *type = (ptr_definition *)argi[i].type;
61 /* paranoid check: really correct type */
62 if (argi[i].options&POLYTYPE) {
63 while (*type != NULL)
64 if (sub_type(arg->type,*type))
65 goto correct;
66 else type++;
67 }
68 else {
69 if (sub_type(arg->type,(ptr_definition)type)) goto correct;
70 }
71 /* type incorrect */
72 if (argi[i].options&JUSTFAIL) return FALSE;
73 Errorline("Illegal argument in %P.\n",funct);
74 return (c_abort());
75 /* correct */
76 correct:;
77 }
78 /* missing value - do we need it */
79 else if (!(argi[i].options&NOVALUE)) allvalues=0;
80 }
81 /* argument missing */
82 else {
83 argo[i]=NULL;
84 if (argi[i].options&MANDATORY) {
85 Errorline("Missing argument '%s' in %P.\n",argi[i].feature,funct);
86 return (c_abort());
87 }
88 else if (argi[i].options&REQUIRED) allargs=0;
89 }
90 }
91 if (allargs)
92 if (allvalues) {
93 return fun(argo,result,funct,info);
94 }
95 else {
96 for (i=0;i<num;i++) {
97 /* if arg present and should be evaled but has no value */
98 if (argo[i] && !(argi[i].options&UNEVALED) && !argo[i]->value_3)
99 residuate(argo[i]);
100 }
101 }
102 else curry();
103 return TRUE;
104 }
105
106 /* DENYS: BYTEDATA */
107
108 /******** MAKE_BYTEDATA
109 construct a psi term of the given sort whose value points
110 to a bytedata block that can hold the given number of bytes
111 */
112 static ptr_psi_term
113 make_bytedata(sort,bytes)
114 ptr_definition sort;
115 unsigned long bytes;
116 {
117 ptr_psi_term temp_result;
118 char *b = (char *) heap_alloc(bytes+sizeof(bytes));
119 *((long *) b) = bytes;
120 bzero(b+sizeof(bytes),bytes);
121 temp_result=stack_psi_term(0);
122 temp_result->type=sort;
123 temp_result->value_3=(GENERIC)b;
124 return temp_result;
125 }
126
127 #define BYTEDATA_SIZE(X) (*(unsigned long *)(X->value_3))
128 #define BYTEDATA_DATA(X) ((char*)((char*)X->value_3 + sizeof(unsigned long)))
129
130 /* BIT VECTORS *
131 ***************/
132
133 /******** C_MAKE_BITVECTOR
134 make a bitvector that can hold at least the given number of bits
135 */
136
137 static long
138 make_bitvector_internal(args,result,funct)
139 ptr_psi_term args[],result,funct;
140 {
141 long bits = *(REAL *)args[0]->value_3;
142 if (bits < 0) {
143 Errorline("negative argument in %P.\n",funct);
144 return FALSE; }
145 else {
146 unsigned long bytes = bits / sizeof(char);
147 ptr_psi_term temp_result;
148 if ((bits % sizeof(char)) != 0) bytes++;
149 temp_result = make_bytedata(sys_bitvector,bytes);
150 push_goal(unify,temp_result,result,NULL);
151 return TRUE; }
152 }
153
154 static long
155 c_make_bitvector()
156 {
157 psi_arg args[1];
158 SETARG(args,0, "1" , integer , REQUIRED );
159 return call_primitive(make_bitvector_internal,NARGS(args),args,0);
160 }
161
162 #define BV_AND 0
163 #define BV_OR 1
164 #define BV_XOR 2
165
166 static long
167 bitvector_binop_code(bv1,bv2,result,op)
168 unsigned long *bv1,*bv2;
169 ptr_psi_term result;
170 GENERIC op; // changed to GENERIC 2.16 no effect DJD
171 {
172 unsigned long size1 = *bv1;
173 unsigned long size2 = *bv2;
174 unsigned long size3 = (size1>size2)?size1:size2;
175 ptr_psi_term temp_result = make_bytedata(sys_bitvector,size3);
176 unsigned char *s1 = ((unsigned char*)bv1)+sizeof(size1);
177 unsigned char *s2 = ((unsigned char*)bv2)+sizeof(size2);
178 unsigned char *s3 = ((unsigned char *) temp_result->value_3) + sizeof(size3);
179 unsigned long i;
180 switch ((long)op) { // added cast DJD 2.16
181 case BV_AND:
182 for(i=0;i<size3;i++) s3[i] = s1[i] & s2[i];
183 if (size1<size2) for(;i<size2;i++) s3[i] = 0;
184 else for(;i<size1;i++) s3[i] = 0;
185 break;
186 case BV_OR:
187 for(i=0;i<size3;i++) s3[i] = s1[i] | s2[i];
188 if (size1<size2) for(;i<size2;i++) s3[i] = s2[i];
189 else for(;i<size1;i++) s3[i] = s1[i];
190 break;
191 case BV_XOR:
192 for(i=0;i<size3;i++) s3[i] = s1[i] ^ s2[i];
193 if (size1<size2) for(;i<size2;i++) s3[i] = (unsigned char) 0 ^ s2[i];
194 else for(;i<size1;i++) s3[i] = s1[i] ^ (unsigned char) 0;
195 break;
196 default: return (c_abort());
197 }
198 push_goal(unify,temp_result,result,NULL);
199 return TRUE;
200 }
201
202 /******** BITVECTOR_BINOP
203 */
204 // DJD
205 static long
206 bitvector_binop_internal(args,result,funct,op)
207 ptr_psi_term *args,result,funct;
208 GENERIC op; // changed to GENERIC 2.16 DJD
209 {
210 return bitvector_binop_code((unsigned long *)args[0]->value_3,
211 (unsigned long *)args[1]->value_3,
212 result,(GENERIC)op);
213 }
214
215 static long
216 bitvector_binop(op)
217 long op;
218 {
219 psi_arg args[2];
220 SETARG(args,0, "1" , sys_bitvector , REQUIRED );
221 SETARG(args,1, "2" , sys_bitvector , REQUIRED );
222 return call_primitive(bitvector_binop_internal,NARGS(args),args,(GENERIC)op);
223 }
224
225 static long
226 c_bitvector_and()
227 {
228 return bitvector_binop(BV_AND);
229 }
230
231 static long
232 c_bitvector_or()
233 {
234 return bitvector_binop(BV_OR);
235 }
236
237 static long
238 c_bitvector_xor()
239 {
240 return bitvector_binop(BV_XOR);
241 }
242
243 #define BV_NOT 0
244 #define BV_COUNT 1
245
246 static long
247 bitvector_unop_code(bv1,result,op)
248 unsigned long *bv1;
249 ptr_psi_term result;
250 int op;
251 {
252 unsigned long size1 = *bv1;
253 unsigned char *s1 = ((unsigned char*)bv1)+sizeof(size1);
254 unsigned long i;
255 ptr_psi_term temp_result;
256 unsigned char *s3;
257 switch (op) {
258 case BV_NOT:
259 temp_result = make_bytedata(sys_bitvector,size1);
260 s3 = ((unsigned char *) temp_result->value_3) + sizeof(size1);
261 for(i=0;i<size1;i++) s3[i] = ~(s1[i]);
262 break;
263 case BV_COUNT:
264 {
265 int cnt = 0;
266 register unsigned char c;
267 for(i=0;i<size1;i++) {
268 c=s1[i];
269 if (c & 1<<0) cnt++;
270 if (c & 1<<1) cnt++;
271 if (c & 1<<2) cnt++;
272 if (c & 1<<3) cnt++;
273 if (c & 1<<4) cnt++;
274 if (c & 1<<5) cnt++;
275 if (c & 1<<6) cnt++;
276 if (c & 1<<7) cnt++; }
277 return unify_real_result(result,(REAL) cnt);
278 }
279 break;
280 default: return (c_abort());
281 }
282 push_goal(unify,temp_result,result,NULL);
283 return TRUE;
284 }
285
286 /******** BITVECTOR_UNOP
287 */
288
289 static long
290 bitvector_unop_internal(args,result,funct,op)
291 ptr_psi_term args[],result,funct;
292 GENERIC op;
293 {
294 return bitvector_unop_code((unsigned long *)args[0]->value_3,
295 result,(GENERIC) op);
296 }
297
298 static long
299 bitvector_unop(op)
300 long op;
301 {
302 psi_arg args[1];
303 SETARG(args,0, "1" , sys_bitvector , REQUIRED );
304 return call_primitive(bitvector_unop_internal,NARGS(args),args,(GENERIC)op);
305 }
306
307 static long
308 c_bitvector_not()
309 {
310 return bitvector_unop(BV_NOT);
311 }
312
313 static long
314 c_bitvector_count()
315 {
316 return bitvector_unop(BV_COUNT);
317 }
318
319 #define BV_GET 0
320 #define BV_SET 1
321 #define BV_CLEAR 2
322
323 static long
324 bitvector_bit_code(bv1,idx,result,op,funct)
325 unsigned long * bv1;
326 long idx;
327 ptr_psi_term result,funct;
328 int op;
329 {
330 unsigned long size1 = *bv1;
331 unsigned char *s1 = ((unsigned char*)bv1)+sizeof(size1);
332 unsigned long i = idx / sizeof(char);
333 int j = idx % sizeof(char);
334 ptr_psi_term temp_result;
335 unsigned char *s2;
336 if (idx<0 || idx>=size1) {
337 Errorline("Index out of bound in %P.\n",funct);
338 return FALSE; }
339 switch (op) {
340 case BV_GET:
341 return unify_real_result(result,(REAL)((s1[i] & (1<<j))?1:0));
342 break;
343 case BV_SET:
344 temp_result = make_bytedata(sys_bitvector,size1);
345 s2 = ((unsigned char *) temp_result->value_3) + sizeof(size1);
346 bcopy(s1,s2,size1);
347 s2[i] |= 1<<j;
348 break;
349 case BV_CLEAR:
350 temp_result = make_bytedata(sys_bitvector,size1);
351 s2 = ((unsigned char *) temp_result->value_3) + sizeof(size1);
352 bcopy(s1,s2,size1);
353 s2[i] &= ~ (1<<j);
354 break;
355 }
356 push_goal(unify,temp_result,result,NULL);
357 return TRUE;
358 }
359
360 static long
361 bitvector_bit_internal(args,result,funct,op)
362 ptr_psi_term args[],result,funct;
363 GENERIC op;
364 {
365 return bitvector_bit_code((unsigned long *)args[0]->value_3,
366 (long)*((REAL*)args[1]->value_3),
367 result,(GENERIC)op,funct);
368 }
369
370 static long
371 bitvector_bit(op)
372 long op;
373 {
374 psi_arg args[2];
375 SETARG(args,0, "1" , sys_bitvector , REQUIRED );
376 SETARG(args,1, "2" , integer , REQUIRED );
377 return call_primitive(bitvector_bit_internal,NARGS(args),args,(GENERIC)op);
378 }
379
380 static long
381 c_bitvector_get()
382 {
383 return bitvector_bit(BV_GET);
384 }
385
386 static long
387 c_bitvector_set()
388 {
389 return bitvector_bit(BV_SET);
390 }
391
392 static long
393 c_bitvector_clear()
394 {
395 return bitvector_bit(BV_CLEAR);
396 }
397
398 /* REGULAR EXPRESSIONS *
399 ***********************/
400
401 #include "regexp/regexp.h"
402
403 void
404 regerror(s)
405 char*s;
406 {
407 fprintf(stderr,"Regexp Error: %s\n",s);
408 }
409
410 /******** C_REGEXP_COMPILE
411 given a string returns, compiles it into a regexp structure,
412 then copies that structure into a bytedata block on the heap.
413 */
414
415 static long
416 regexp_compile_internal(args,result,funct)
417 ptr_psi_term args[],result,funct;
418 {
419 ptr_psi_term temp_result;
420 regexp * re = regcomp((char *)args[0]->value_3);
421 long bytes;
422 if (re == NULL) {
423 Errorline("compilation of regular expression failed in %P.\n",funct);
424 return (c_abort()); }
425 /* compute the size of the regexp stuff. this is essentially the size
426 of the regexp structure + the size of the program (bytecode) including
427 the final END opcode (i.e. 0), hence the + 1, minus the bytes that we
428 have counted twice, i.e. those between the start of the program and
429 the computed end of the regexp structure (i.e. in case a regexp
430 struct is larger, maybe to respect alignment constraints, than it has
431 to be, and also to count the 1 byte of program included in the decl
432 of struct regexp */
433 bytes = last_regsize();
434 temp_result = make_bytedata(sys_regexp,bytes);
435 /* now let's copy the regexp stuff into the bytedata block. The regmust
436 field must be treated specially because it is a pointer into program:
437 we cannot simply change it to reflect the location where the program
438 will be copied to because that may well change over time: the gc may
439 relocate the bytedata block. Instead, we convert regmust into an
440 offset and each time we need to pass it to regexec or regsub we must
441 first convert it back into a pointer then back into an offset when we
442 are done. Note that, if regmust is NULL we must leave it that way */
443 if (re->regmust != NULL)
444 re->regmust = (char *) ((unsigned long) (re->regmust - (char *)re));
445 bcopy((char*)re,((char*)temp_result->value_3)+sizeof(unsigned long),bytes);
446 free(re); /* free the regexp: no longer needed */
447 /* return result */
448 push_goal(unify,temp_result,result,NULL);
449 return TRUE;
450 }
451
452 static long
453 c_regexp_compile()
454 {
455 psi_arg args[1];
456 SETARG(args,0, "1" , quoted_string , REQUIRED );
457 return call_primitive(regexp_compile_internal,NARGS(args),args,0);
458 }
459
460 /******** C_REGEXP_EXECUTE
461 Attempts to match a regexp with a string
462 regexp_execute(RE:regexp,S:string) -> @(0=>(S0,E0),(S1,E1),...)
463 regexp_execute(RE:regexp,S:string,@(N=>(SN,EN),...)) -> boolean
464 2nd form only instantiates the bounds requested in the mask (3rd arg)
465 and returns a boolean so that it can be used as a predicate.
466 The optional argument "offset" specifies an offset into the string.
467 */
468
469 static long regexp_execute_internal(args,result,funct)
470 ptr_psi_term args[],result,funct;
471 {
472 regexp * re = (regexp*)(((char *)args[0]->value_3)+sizeof(unsigned long));
473 char * must = re->regmust;
474 long offset = 0;
475 // long success = TRUE;
476 /* check that args[3] aka "offset" is valid if present */
477 if (args[3]) {
478 offset = *(REAL*)args[3]->value_3;
479 if (offset < 0 || offset > strlen((char*)args[1]->value_3)) {
480 Errorline("Illegal offset in %P.\n",funct);
481 return (c_abort()); }
482 }
483 /* convert regmust from offset into a pointer if not NULL */
484 if (must != NULL)
485 re->regmust = (char*)re+(unsigned long)must;
486 /* perform operation */
487 if (regexec(re,((char *)args[1]->value_3) + offset) == 0) {
488 if (must != NULL) re->regmust = must; /* back into an offset */
489 return FALSE;
490 }
491 else {
492 /* construct result of match */
493 char **sp = re->startp;
494 char **ep = re->endp;
495 int i;
496 char buffer_loc[5]; /* in case NSUBEXP ever gets increased */
497 ptr_node n3;
498 if (must != NULL) re->regmust = must; /* back into an offset */
499 if (args[2]) {
500 /* only instantiate the numeric features present in args[2]
501 then return true */
502 for (i=0;i<NSUBEXP;i++,sp++,ep++) {
503 if (*sp==NULL) break;
504 (void)snprintf(buffer_loc,5,"%d",i);
505 n3=find(FEATCMP,buffer_loc,args[2]->attr_list);
506 if (n3) {
507 ptr_psi_term psi = (ptr_psi_term) n3->data;
508 /* need to add 1 to these offsets because somehow life strings
509 are 1-based rather than 0-based. Who is the moron who made
510 that decision? This isn't Pascal! */
511 ptr_psi_term bounds = stack_pair(stack_int(*sp - (char *)args[1]->value_3 + 1),
512 stack_int(*ep - (char *)args[1]->value_3 + 1));
513 push_goal(unify,psi,bounds,NULL);
514 }
515 }
516 /* return true */
517 unify_bool_result(result,TRUE);
518 }
519 else {
520 /* create a term to represent all the groups and return it */
521 ptr_psi_term psi = stack_psi_term(4);
522 psi->type = top;
523 for (i=0;i<NSUBEXP;i++,sp++,ep++) {
524 if (*sp==NULL) break;
525 (void)snprintf(buffer_loc,5,"%d",i);
526 { ptr_psi_term bounds = stack_pair(stack_int(*sp - (char *)args[1]->value_3 + 1),
527 stack_int(*ep - (char *)args[1]->value_3 + 1));
528 stack_insert_copystr(buffer_loc,&(psi->attr_list),(GENERIC)bounds); }
529 }
530 /* return the new term */
531 push_goal(unify,psi,result,NULL);
532 }
533 return TRUE;
534 }
535 }
536
537 static long
538 c_regexp_execute()
539 {
540 psi_arg args[4];
541 SETARG(args,0, "1" , sys_regexp , REQUIRED );
542 SETARG(args,1, "2" , quoted_string , REQUIRED );
543 SETARG(args,2, "3" , top , OPTIONAL|NOVALUE );
544 SETARG(args,3, "offset" , integer , OPTIONAL );
545 return call_primitive(regexp_execute_internal,NARGS(args),args,0);
546 }
547
548 /* FILE STREAMS *
549 ****************/
550
551 /* when a fp is opened for updating an input operation
552 should not follow an output operation without an intervening
553 flush or file positioning operation; and the other way around
554 too. I am going to keep track of what operations have been
555 applied so that flush will be automatically invoked when
556 necessary */
557
558 #define FP_NONE 0
559 #define FP_INPUT 1
560 #define FP_OUTPUT 2
561
562 typedef struct a_stream {
563 FILE *fp;
564 int op;
565 } *ptr_stream;
566
567 #define FP_PREPARE(s,OP) \
568 if (s->op != OP && s->op != FP_NONE) fflush(s->fp); \
569 s->op = OP;
570
571 ptr_psi_term fileptr2stream(fp,typ)
572 FILE*fp;
573 ptr_definition typ; // removed * DJD
574 {
575 ptr_psi_term result = make_bytedata(typ,sizeof(struct a_stream));
576 ((ptr_stream)BYTEDATA_DATA(result))->fp = fp;
577 ((ptr_stream)BYTEDATA_DATA(result))->op = FP_NONE;
578 return result;
579 }
580
581 static long
582 int2stream_internal(args,result,funct)
583 ptr_psi_term args[],result,funct;
584 {
585 FILE *fp = fdopen((int)*(REAL*)args[0]->value_3,
586 (char*)args[1]->value_3);
587 if (fp==NULL) return FALSE;
588 else {
589 push_goal(unify,fileptr2stream(fp,sys_stream),result,NULL); // added & DJD
590 /* ptr_psi_term temp_result = make_bytedata(sys_stream,sizeof(fp));
591 *(FILE**)BYTEDATA_DATA(temp_result) = fp;
592 push_goal(unify,temp_result,result,NULL); */
593 return TRUE;
594 }
595 }
596
597 static long
598 c_int2stream()
599 {
600 psi_arg args[2];
601 SETARG(args,0,"1",integer,REQUIRED);
602 SETARG(args,1,"2",quoted_string,REQUIRED);
603 return call_primitive(int2stream_internal,NARGS(args),args,0);
604 }
605
606 static long
607 fopen_internal(args,result,funct)
608 ptr_psi_term args[],result,funct;
609 {
610 FILE *fp = fopen((char*)args[0]->value_3,
611 (char*)args[1]->value_3);
612 if (fp==NULL) return FALSE;
613 else {
614 /* ptr_psi_term temp_result = make_bytedata(sys_file_stream,sizeof(fp));
615 *(FILE**)BYTEDATA_DATA(temp_result) = fp;
616 */
617 push_goal(unify,fileptr2stream(fp,sys_file_stream),result,NULL); // added & DJD
618 return TRUE;
619 }
620 }
621
622 static long
623 c_fopen()
624 {
625 psi_arg args[2];
626 SETARG(args,0, "1" , quoted_string , REQUIRED );
627 SETARG(args,1, "2" , quoted_string , REQUIRED );
628 return call_primitive(fopen_internal,NARGS(args),args,0);
629 }
630
631 static long
632 fclose_internal(args,result,funct)
633 ptr_psi_term args[],result,funct;
634 {
635 if (fclose(((ptr_stream)BYTEDATA_DATA(args[0]))->fp) != 0)
636 return FALSE;
637 else
638 return TRUE;
639 }
640
641 static long
642 c_fclose()
643 {
644 psi_arg args[1];
645 SETARG(args,0, "1" , sys_stream , REQUIRED );
646 return call_primitive(fclose_internal,NARGS(args),args,0);
647 }
648
649 static long
650 fwrite_internal(args,result,funct)
651 ptr_psi_term args[],result,funct;
652 {
653 ptr_stream srm = (ptr_stream)BYTEDATA_DATA(args[0]);
654 /*FILE* fp = *(FILE**)BYTEDATA_DATA(args[0]);*/
655 char* txt = (char*)args[1]->value_3;
656 FP_PREPARE(srm,FP_OUTPUT);
657 if (txt && *txt!='\0' &&
658 fwrite((void*)txt,sizeof(char),strlen(txt),srm->fp)<=0)
659 return FALSE;
660 return TRUE;
661 }
662
663 static long
664 c_fwrite()
665 {
666 psi_arg args[2];
667 SETARG(args,0,"1",sys_stream,MANDATORY);
668 SETARG(args,1,"2",quoted_string,MANDATORY);
669 return call_primitive(fwrite_internal,NARGS(args),args,0);
670 }
671
672 static long
673 fflush_internal(args,result,funct)
674 ptr_psi_term args[],result,funct;
675 {
676 ptr_stream srm = (ptr_stream)BYTEDATA_DATA(args[0]);
677 /*FILE* fp = *(FILE**)BYTEDATA_DATA(args[0]);*/
678 srm->op = FP_NONE;
679 if (fflush(srm->fp)!=0) return FALSE;
680 return TRUE;
681 }
682
683 static long
684 c_fflush()
685 {
686 psi_arg args[1];
687 SETARG(args,0,"1",sys_stream,MANDATORY);
688 return call_primitive(fflush_internal,NARGS(args),args,0);
689 }
690
691 static long
692 get_buffer_internal(args,result,funct)
693 ptr_psi_term args[],result,funct;
694 {
695 ptr_stream srm = (ptr_stream)BYTEDATA_DATA(args[0]);
696 /*FILE* fp = *(FILE**)BYTEDATA_DATA(args[0]);*/
697 long size = *(REAL*)args[1]->value_3;
698 ptr_psi_term t = stack_psi_term(4);
699 t->type = quoted_string;
700 t->value_3=(GENERIC)heap_alloc(size+1);
701 bzero((char*)t->value_3,size+1);
702 FP_PREPARE(srm,FP_INPUT);
703 if (fread((void*)t->value_3,sizeof(char),size,srm->fp) <= 0)
704 return FALSE;
705 push_goal(unify,t,result,NULL);
706 return TRUE;
707 }
708
709 static long
710 c_get_buffer()
711 {
712 psi_arg args[2];
713 SETARG(args,0,"1",sys_stream,REQUIRED);
714 SETARG(args,1,"2",integer,REQUIRED);
715 return call_primitive(get_buffer_internal,NARGS(args),args,0);
716 }
717
718
719 /* find the first match for character c starting from index idx in
720 buffer buf. if found place new buffer and index in rbuf and
721 ridx and return 1, else return 0
722 */
723 int
724 text_buffer_next(buf,idx,c,rbuf,ridx)
725 struct text_buffer *buf,**rbuf;
726 char c;
727 int idx,*ridx;
728 {
729 while (buf) {
730 while (idx<buf->top)
731 if (buf->data[idx] == c) {
732 *rbuf=buf;
733 *ridx=idx;
734 return 1;
735 }
736 else idx++;
737 buf=buf->next;
738 idx=0;
739 }
740 return 0;
741 }
742
743 /* compare string str with text in buffer buf starting at index idx.
744 if the text to the end matches a prefix of the string, return
745 pointer to remaining suffix of str to be matched, else return 0.
746 */
747 char*
748 text_buffer_cmp(buf,idx,str)
749 struct text_buffer *buf;
750 int idx;
751 char *str;
752 {
753 while (buf) {
754 while (idx<buf->top)
755 if (!*str || buf->data[idx] != *str)
756 return 0;
757 else { idx++; str++; }
758 if (!*str && !buf->next) return str;
759 else {
760 buf=buf->next;
761 idx=0;
762 }
763 }
764 return 0;
765 }
766
767 /* add a character at the end of a buffer. if the buffer is
768 full, allocate a new buffer and link it to the current one,
769 then overwrite the variable holding the pointer to the
770 current buffer with the pointer to the new buffer.
771 */
772 void
773 text_buffer_push(buf,c)
774 struct text_buffer **buf;
775 char c;
776 {
777 if ((*buf)->top < TEXTBUFSIZE)
778 (*buf)->data[(*buf)->top++] = c;
779 else {
780 (*buf)->next = (struct text_buffer *)
781 malloc(sizeof(struct text_buffer));
782 if (!(*buf)->next) {
783 fprintf(stderr,"Fatal error: malloc failed in text_buffer_push\n");
784 exit(EXIT_FAILURE);
785 }
786 bzero((char*)(*buf)->next,sizeof(struct text_buffer));
787 *buf = (*buf)->next;
788 (*buf)->top = 1;
789 (*buf)->data[0]=c;
790 }
791 }
792
793 /* free a linked list of buffers */
794 void
795 text_buffer_free(buf)
796 struct text_buffer *buf;
797 {
798 struct text_buffer *next;
799 while (buf) {
800 next = buf->next;
801 free(buf);
802 buf=next;
803 }
804 }
805
806 static long
807 get_record_internal(args,result,funct)
808 ptr_psi_term args[],result,funct;
809 {
810 struct text_buffer rootbuf;
811 struct text_buffer *curbuf = &rootbuf;
812 struct text_buffer *lastbuf = &rootbuf;
813 int lastidx = 0,size;
814 ptr_stream srm = (ptr_stream)BYTEDATA_DATA(args[0]);
815 FILE *fp = srm->fp; /*FILE* fp = *(FILE**)BYTEDATA_DATA(args[0]);*/
816 char *sep = (char*)args[1]->value_3;
817 int c;
818 ptr_psi_term t;
819 char *cursep = sep;
820
821 FP_PREPARE(srm,FP_INPUT);
822 bzero((char*)&rootbuf,sizeof(rootbuf));
823 if (!sep || !*sep) {
824 /* no separator: just grab as much as you can */
825 while ((c=getc(fp)) != EOF)
826 text_buffer_push(&curbuf,(char)c);
827 goto PackUpAndLeave;
828 }
829
830 if (sep[1]=='\0') {
831 /* only one char in string */
832 while ((c=getc(fp)) != EOF) {
833 text_buffer_push(&curbuf,(char)c);
834 if (c==*sep) break;
835 }
836 goto PackUpAndLeave;
837 }
838
839 /* general case: multicharacter separator */
840
841 WaitForStart:
842 if ((c=getc(fp)) == EOF) goto PackUpAndLeave;
843 text_buffer_push(&curbuf,(char)c);
844 if (c==*sep) {
845 cursep = sep+1;
846 lastbuf=curbuf;
847 lastidx=curbuf->top - 1;
848 goto MatchNext;
849 }
850 else goto WaitForStart;
851
852 MatchNext:
853 if (!*cursep || (c=getc(fp))==EOF) goto PackUpAndLeave;
854 text_buffer_push(&curbuf,(char)c);
855 if (c!=*cursep) goto TryAgain;
856 cursep++;
857 goto MatchNext;
858
859 TryAgain:
860 if (!text_buffer_next(lastbuf,lastidx+1,*sep,&lastbuf,&lastidx))
861 goto WaitForStart;
862 if (!(cursep=text_buffer_cmp(lastbuf,lastidx,sep)))
863 goto TryAgain;
864 goto MatchNext;
865
866 PackUpAndLeave:
867 /* compute how much space we need */
868 for(lastbuf=&rootbuf,size=0;lastbuf!=NULL;lastbuf=lastbuf->next)
869 size += lastbuf->top;
870 t=stack_psi_term(0);
871 t->type=quoted_string;
872 t->value_3=(GENERIC)heap_alloc(size+1);
873 for(lastbuf=&rootbuf,sep=(char*)t->value_3;
874 lastbuf!=NULL;sep+=lastbuf->top,lastbuf=lastbuf->next)
875 bcopy(lastbuf->data,sep,lastbuf->top);
876 ((char*)t->value_3)[size]='\0';
877 text_buffer_free(rootbuf.next);
878 push_goal(unify,t,result,NULL);
879 return TRUE;
880 }
881
882 static long
883 c_get_record()
884 {
885 psi_arg args[2];
886 SETARG(args,0,"1",sys_stream,REQUIRED);
887 SETARG(args,1,"2",quoted_string,REQUIRED);
888 return call_primitive(get_record_internal,NARGS(args),args,0);
889 }
890
891 static long
892 get_code_internal(args,result,funct)
893 ptr_psi_term args[],result,funct;
894 {
895 ptr_stream srm = (ptr_stream)BYTEDATA_DATA(args[0]);
896 int c;
897 FP_PREPARE(srm,FP_INPUT);
898 if ((c=getc(srm->fp)) == EOF) return FALSE;
899 else return unify_real_result(result,(REAL)c);
900 }
901
902 static long
903 c_get_code()
904 {
905 psi_arg args[1];
906 SETARG(args,0,"1",sys_stream,REQUIRED);
907 return call_primitive(get_code_internal,NARGS(args),args,0);
908 }
909
910 static long
911 ftell_internal(args,result,funct)
912 ptr_psi_term args[],result,funct;
913 {
914 ptr_stream srm = (ptr_stream)BYTEDATA_DATA(args[0]);
915 if (srm->op != FP_NONE || srm->op != FP_INPUT) {
916 fflush(srm->fp);
917 srm->op = FP_NONE;
918 }
919 return unify_real_result(result,(REAL)ftell(srm->fp));
920 /* *(FILE**)BYTEDATA_DATA(args[0])));*/
921 }
922
923 static long
924 c_ftell()
925 {
926 psi_arg args[1];
927 SETARG(args,0,"1",sys_file_stream,REQUIRED);
928 return call_primitive(ftell_internal,NARGS(args),args,0);
929 }
930
931 #ifndef SEEK_SET
932 #define SEEK_SET 0
933 #endif
934 #ifndef SEEK_CUR
935 #define SEEK_CUR 1
936 #endif
937 #ifndef SEEK_END
938 #define SEEK_END 2
939 #endif
940
941 static long
942 fseek_internal(args,result,funct)
943 ptr_psi_term args[],result,funct;
944 {
945 ptr_stream srm = (ptr_stream)BYTEDATA_DATA(args[0]);
946 srm->op = FP_NONE;
947 return
948 (fseek(srm->fp ,
949 (long)*(REAL*)args[1]->value_3,
950 args[2]?(long)*(REAL*)args[2]->value_3:SEEK_SET) < 0)
951 ?FALSE:TRUE;
952 }
953
954 static long
955 c_fseek()
956 {
957 psi_arg args[3];
958 SETARG(args,0,"1",sys_file_stream,MANDATORY);
959 SETARG(args,1,"2",integer,MANDATORY);
960 SETARG(args,2,"3",integer,OPTIONAL);
961 return call_primitive(fseek_internal,NARGS(args),args,0);
962 }
963
964 static long
965 stream2sys_stream_internal(args,result,funct)
966 ptr_psi_term args[],result,funct;
967 {
968 push_goal(unify,fileptr2stream((FILE*)args[0]->value_3,sys_stream),
969 result,NULL); // added & DJD
970 return TRUE;
971 }
972
973 static long
974 c_stream2sys_stream()
975 {
976 psi_arg args[1];
977 SETARG(args,0,"1",stream,REQUIRED);
978 return call_primitive(stream2sys_stream_internal,NARGS(args),args,0);
979 }
980
981 static long
982 sys_stream2stream_internal(args,result,funct)
983 ptr_psi_term args[],result,funct;
984 {
985 ptr_psi_term tmp;
986 tmp=stack_psi_term(4);
987 tmp->type=stream;
988 tmp->value_3=(GENERIC)((ptr_stream)BYTEDATA_DATA(args[0]))->fp;
989 push_goal(unify,tmp,result,NULL);
990 return TRUE;
991 }
992
993 static long
994 c_sys_stream2stream()
995 {
996 psi_arg args[1];
997 SETARG(args,0,"1",sys_stream,REQUIRED);
998 return call_primitive(sys_stream2stream_internal,NARGS(args),args,0);
999 }
1000
1001 /* SOCKETS AND NETWORKING *
1002 **************************/
1003
1004 #include <sys/socket.h>
1005 #include <netinet/in.h>
1006 #include <sys/un.h>
1007 #include <netdb.h>
1008 #include <arpa/inet.h>
1009 #include <ctype.h>
1010
1011 static long
1012 socket_internal(args,result,funct)
1013 ptr_psi_term args[],result,funct;
1014 {
1015 int addr_family=AF_INET,type=SOCK_STREAM,protocol=0;
1016 char *s;
1017 int fd;
1018
1019 if (args[0]) {
1020 s=(char*)args[0]->value_3;
1021 if (!strcmp(s,"AF_UNIX")) addr_family=AF_UNIX;
1022 else if (!strcmp(s,"AF_INET")) addr_family=AF_INET;
1023 else {
1024 Errorline("Unknown address family in %P.\n",funct);
1025 return FALSE; }
1026 }
1027
1028 if (args[1]) {
1029 s=(char*)args[1]->value_3;
1030 if (!strcmp(s,"SOCK_STREAM")) type=SOCK_STREAM;
1031 else if (!strcmp(s,"SOCK_DGRAM" )) type=SOCK_DGRAM;
1032 else if (!strcmp(s,"SOCK_RAW" )) {
1033 Errorline("SOCK_RAW not supported in %P.\n",funct);
1034 return FALSE; }
1035 else {
1036 Errorline("Unknown socket type in %P.\n",funct);
1037 return FALSE; }
1038 }
1039
1040 if ((fd=socket(addr_family,type,protocol))<0)
1041 return FALSE;
1042
1043 { FILE*fp = fdopen(fd,"r+");
1044 // ptr_psi_term t;
1045
1046 if (fp==NULL) {
1047 Errorline("fdopen failed on socket in %P.\n",funct);
1048 return FALSE;
1049 }
1050
1051 /* t = make_bytedata(sys_socket_stream,sizeof(fp));
1052 *(FILE**)BYTEDATA_DATA(t) = fp;*/
1053 push_goal(unify,fileptr2stream(fp,sys_socket_stream),result,NULL); // added & DJD
1054 }
1055 return TRUE;
1056 }
1057
1058 static long
1059 c_socket()
1060 {
1061 psi_arg args[2];
1062 SETARG(args,0,"1",quoted_string,OPTIONAL);
1063 SETARG(args,1,"2",quoted_string,OPTIONAL);
1064 return call_primitive(socket_internal,NARGS(args),args,0);
1065 }
1066
1067 int
1068 is_ipaddr(s)
1069 char*s;
1070 {
1071 if (s==NULL) return 0;
1072 while (*s)
1073 if (!isdigit(*s) && *s!='.') return 0;
1074 else s++;
1075 return 1;
1076 }
1077
1078 static long
1079 bind_or_connect_internal(args,result,funct,info)
1080 ptr_psi_term args[],result,funct;
1081 void*info;
1082 {
1083 int fd = fileno(((ptr_stream)BYTEDATA_DATA(args[0]))->fp);
1084 int do_bind = info==NULL;
1085
1086 if (args[1] || args[2]) {
1087 /* bind or connect in the internet domain */
1088 struct sockaddr_in name_loc;
1089 char* hostname = args[1]?(char*)args[1]->value_3:NULL;
1090 // int port;
1091 if (!args[2]) {
1092 Errorline("Missing port number in %P.\n",funct);
1093 return FALSE;
1094 }
1095
1096 bzero((char*)&name_loc,sizeof(name_loc));
1097 name_loc.sin_family = AF_INET;
1098 name_loc.sin_port = htons((unsigned short)*(REAL*)args[2]->value_3);
1099
1100 if (!hostname || *hostname=='\0' || !strcasecmp(hostname,"localhost"))
1101 name_loc.sin_addr.s_addr = INADDR_ANY;
1102 else {
1103 struct hostent * h;
1104 int ipaddr;
1105 if ((ipaddr=is_ipaddr(hostname))) {
1106 int i = inet_addr(hostname);
1107 h = gethostbyaddr((char*)&i,sizeof(i),AF_INET);
1108 } else h = gethostbyname(hostname);
1109 if (h==NULL) {
1110 Errorline("%s failed for %P.\n",
1111 ipaddr?"gethostbyaddr":"gethostbyname",funct);
1112 return FALSE;
1113 }
1114 bcopy(h->h_addr,(char*)&(name_loc.sin_addr.s_addr),h->h_length);
1115 }
1116 if ((do_bind?
1117 bind(fd,(struct sockaddr *)&name_loc,sizeof(name_loc)):
1118 connect(fd,(struct sockaddr *)&name_loc,sizeof(name_loc))) < 0) {
1119 Errorline("%s failed in %P.\n",do_bind?"bind":"connect",funct);
1120 return FALSE;
1121 }
1122 }
1123 else if (args[3]) {
1124 /* bind in the unix domain */
1125 struct sockaddr_un name_loc;
1126 char* path = (char*)args[3]->value_3;
1127
1128 name_loc.sun_family = AF_UNIX;
1129 strcpy(name_loc.sun_path,path);
1130
1131 if ((do_bind?
1132 bind(fd,(struct sockaddr *)&name_loc,sizeof(name_loc)):
1133 connect(fd,(struct sockaddr *)&name_loc,sizeof(name_loc))) < 0) {
1134 Errorline("%s failed in %P.\n",do_bind?"bind":"connect",funct);
1135 return FALSE;
1136 }
1137 }
1138 else {
1139 Errorline("Too few arguments in %P.\n",funct);
1140 return FALSE;
1141 }
1142 return TRUE;
1143 }
1144
1145 static long
1146 c_bind()
1147 {
1148 psi_arg args[4];
1149 SETARG(args,0,"1",sys_socket_stream,MANDATORY);
1150 SETARG(args,1,"host",quoted_string,OPTIONAL);
1151 SETARG(args,2,"port",integer,OPTIONAL);
1152 SETARG(args,3,"path",quoted_string,OPTIONAL);
1153 return call_primitive(bind_or_connect_internal,NARGS(args),args,NULL);
1154 }
1155
1156 static long
1157 c_connect()
1158 {
1159 psi_arg args[4];
1160 SETARG(args,0,"1",sys_socket_stream,MANDATORY);
1161 SETARG(args,1,"host",quoted_string,OPTIONAL);
1162 SETARG(args,2,"port",integer,OPTIONAL);
1163 SETARG(args,3,"path",quoted_string,OPTIONAL);
1164 return call_primitive(bind_or_connect_internal,NARGS(args),args,(GENERIC)1);
1165 }
1166
1167 static long
1168 listen_internal(args,result,funct)
1169 ptr_psi_term args[],result,funct;
1170 {
1171 int fd = fileno(((ptr_stream)BYTEDATA_DATA(args[0]))->fp);
1172 int n = *(REAL*)args[1]->value_3;
1173
1174 if (listen(fd,n) < 0) return FALSE;
1175 return TRUE;
1176 }
1177
1178 static long
1179 c_listen()
1180 {
1181 psi_arg args[2];
1182 SETARG(args,0,"1",sys_socket_stream,MANDATORY);
1183 SETARG(args,1,"2",integer,MANDATORY);
1184 return call_primitive(listen_internal,NARGS(args),args,0);
1185 }
1186
1187 static long
1188 accept_internal(args,result,funct)
1189 ptr_psi_term args[],result,funct;
1190 {
1191 int fd = fileno(((ptr_stream)BYTEDATA_DATA(args[0]))->fp);
1192 int s;
1193
1194 if ((s=accept(fd,NULL,NULL)) < 0) return FALSE;
1195 else {
1196 FILE * fp = fdopen(s,"r+");
1197 // ptr_psi_term t;
1198
1199 if (fp==NULL) {
1200 Errorline("fdopen failed on socket in %P.\n",funct);
1201 return FALSE;
1202 }
1203
1204 /* t = make_bytedata(sys_socket_stream,sizeof(fp));
1205 *(FILE**)BYTEDATA_DATA(t) = fp;*/
1206 push_goal(unify,fileptr2stream(fp,sys_socket_stream),result,NULL); // added & DJD
1207 return TRUE;
1208 }
1209 }
1210
1211 static long
1212 c_accept()
1213 {
1214 psi_arg args[1];
1215 SETARG(args,0,"1",sys_socket_stream,REQUIRED);
1216 return call_primitive(accept_internal,NARGS(args),args,0);
1217 }
1218
1219 /* SYSTEM ERRORS *
1220 *****************/
1221
1222 static long
1223 errno_internal(args,result,funct)
1224 ptr_psi_term args[],result,funct;
1225 {
1226 push_goal(unify,stack_int(errno),result,NULL);
1227 return TRUE;
1228 }
1229
1230 static long
1231 c_errno()
1232 {
1233 return call_primitive(errno_internal,0,NULL,0);
1234 }
1235
1236 /* some systems are missing these declarations */
1237 // extern char *sys_errlist[];
1238 // extern int sys_nerr;
1239
1240 static long
1241 errmsg_internal(args,result,funct)
1242 ptr_psi_term args[],result,funct;
1243 {
1244 long n = args[0]?(long)*(REAL*)args[0]->value_3:errno;
1245 // if (n<0 || n>=sys_nerr) return FALSE;
1246 // else {
1247 push_goal(unify,stack_string(strerror(n)),result,NULL);
1248 return TRUE;
1249 // }
1250 }
1251
1252 static long
1253 c_errmsg()
1254 {
1255 psi_arg args[1];
1256 SETARG(args,0, "1" , integer , OPTIONAL );
1257 return call_primitive(errmsg_internal,NARGS(args),args,0);
1258 }
1259
1260 /* MODULES *
1261 ***********/
1262
1263 /******** C_IMPORT_SYMBOL
1264 import a public symbol from another module into the current one,
1265 optionally renaming it.
1266 */
1267
1268 static long
1269 import_symbol_internal(args,result,funct)
1270 ptr_psi_term args[],result,funct;
1271 {
1272 ptr_keyword key;
1273
1274 if (args[1])
1275 key=args[1]->type->keyword;
1276 else
1277 key=hash_lookup(current_module->symbol_table,
1278 args[0]->type->keyword->symbol);
1279
1280 if (key)
1281 if (key->definition->type_def != (def_type)undef) {
1282 Errorline("symbol %s already defined in %P.",key->combined_name,funct);
1283 return FALSE;
1284 }
1285 else key->definition=args[0]->type;
1286 else {
1287 /* adapted from update_symbol in modules.c */
1288 /* Add 'module#symbol' to the symbol table */
1289 key=HEAP_ALLOC(struct wl_keyword);
1290 key->module=current_module;
1291 /* use same name */
1292 key->symbol=args[0]->type->keyword->symbol;
1293 key->combined_name=(char *)
1294 heap_copy_string(make_module_token(current_module,key->symbol));
1295 key->public=FALSE;
1296 key->private_feature=FALSE;
1297 key->definition=args[0]->type; /* use given definition */
1298
1299 hash_insert(current_module->symbol_table,key->symbol,key);
1300 }
1301 return TRUE;
1302 }
1303
1304 static long
1305 c_import_symbol()
1306 {
1307 psi_arg args[2];
1308 SETARG(args,0,"1",top,MANDATORY|UNEVALED);
1309 SETARG(args,1,"as",top,OPTIONAL|NOVALUE|UNEVALED);
1310 return call_primitive(import_symbol_internal,NARGS(args),args,0);
1311 }
1312
1313 /* PROCESSES *
1314 *************/
1315
1316 static long
1317 fork_internal(args,result,funct)
1318 ptr_psi_term args[],result,funct;
1319 {
1320 pid_t id = fork();
1321 if (id < 0) return FALSE;
1322 else return unify_real_result(result,(REAL)id);
1323 }
1324
1325 static long
1326 c_fork()
1327 {
1328 return call_primitive(fork_internal,0,NULL,0);
1329 }
1330
1331 typedef struct {
1332 char * name_str;
1333 ptr_psi_term value_str;
1334 } psi_feature;
1335
1336 #define SETFEATURE(lst,n,nam,val) ((lst[n].name_str=nam),(lst[n].value_str=val))
1337
1338 static long
1339 unify_pterm_result(t,sym,lst,n)
1340 ptr_psi_term t;
1341 ptr_definition sym;
1342 psi_feature lst[];
1343 int n;
1344 {
1345 ptr_psi_term u;
1346 int i;
1347 if (n<0) {
1348 fprintf(stderr,"unify_pterm_result called with n<0: n=%d\n",n);
1349 exit(EXIT_FAILURE);
1350 }
1351 u=stack_psi_term(4);
1352 u->type=sym;
1353 for(i=0;i<n;i++)
1354 (void)stack_insert(FEATCMP,lst[i].name_str,&(u->attr_list),(GENERIC)lst[i].value_str);
1355 push_goal(unify,t,u,NULL);
1356 return TRUE;
1357 }
1358
1359 char *
1360 get_numeric_feature(n)
1361 long n;
1362 {
1363 if (n==1) return one;
1364 else if (n==2) return two;
1365 else if (n==3) return three;
1366 else {
1367 char buf[100];
1368 (void)snprintf(buf,100,"%ld",n);
1369 return heap_copy_string(buf);
1370 }
1371 }
1372
1373 #ifndef WIFEXITED
1374 #include <sys/wait.h>
1375 #endif
1376
1377 ptr_definition sys_process_no_children;
1378 ptr_definition sys_process_exited;
1379 ptr_definition sys_process_signaled;
1380 ptr_definition sys_process_stopped;
1381 ptr_definition sys_process_continued;
1382
1383 static long
1384 unify_wait_result(result,id,status)
1385 ptr_psi_term result;
1386 pid_t id;
1387 int status;
1388 {
1389 int n=2;
1390 long status2;
1391 ptr_definition sym;
1392 psi_feature lst[2];
1393 SETFEATURE(lst,0,one,stack_int(id));
1394 if (id == -1 || status == -1) {
1395 if (errno==ECHILD) {
1396 sym = sys_process_no_children;
1397 n=0;
1398 }
1399 else return FALSE;
1400 }
1401 else if (WIFEXITED(status)) {
1402 SETFEATURE(lst,1,two,stack_int(WEXITSTATUS(status)));
1403 sym = sys_process_exited;
1404 }
1405 else if (WIFSIGNALED(status)) {
1406 SETFEATURE(lst,1,two,stack_int(WTERMSIG(status)));
1407 sym = sys_process_signaled;
1408 }
1409 else if (WIFSTOPPED(status)) {
1410 SETFEATURE(lst,1,two,stack_int(WSTOPSIG(status)));
1411 sym = sys_process_stopped;
1412 }
1413 #ifdef WIFCONTINUED
1414 else if (WIFCONTINUED(status)) {
1415 sym = sys_process_continued;
1416 n=1;
1417 }
1418 #endif
1419 else {
1420 status2 = status;
1421 Errorline("Unexpected wait status: %d",status2);
1422 return FALSE;
1423 }
1424 return unify_pterm_result(result,sym,lst,n);
1425 }
1426
1427 static long
1428 wait_internal(args,result,funct)
1429 ptr_psi_term args[],result,funct;
1430 {
1431 int status;
1432 pid_t id = wait(&status);
1433 return unify_wait_result(result,id,status);
1434 }
1435
1436 static long
1437 c_wait()
1438 {
1439 return call_primitive(wait_internal,0,NULL,0);
1440 }
1441
1442 static long
1443 waitpid_internal(args,result,funct)
1444 ptr_psi_term args[],result,funct;
1445 {
1446 int status;
1447 pid_t id = waitpid((pid_t)(long)*(REAL*)args[0]->value_3,&status,
1448 args[1]?(int)(long)*(REAL*)args[1]->value_3:0);
1449 return unify_wait_result(result,id,status);
1450 }
1451
1452 static long
1453 c_waitpid()
1454 {
1455 psi_arg args[2];
1456 SETARG(args,0,"1",integer,REQUIRED);
1457 SETARG(args,1,"2",integer,OPTIONAL);
1458 return call_primitive(waitpid_internal,NARGS(args),args,0);
1459 }
1460
1461 static long
1462 kill_internal(args,result,funct)
1463 ptr_psi_term args[],result,funct;
1464 {
1465 return (kill((pid_t)*(REAL*)args[0]->value_3,
1466 (int)*(REAL*)args[1]->value_3)==0)?TRUE:FALSE;
1467 }
1468
1469 static long
1470 c_kill()
1471 {
1472 psi_arg args[2];
1473 SETARG(args,0,"1",integer,MANDATORY);
1474 SETARG(args,1,"2",integer,MANDATORY);
1475 return call_primitive(kill_internal,NARGS(args),args,0);
1476 }
1477
1478 /* MISCELLANEOUS *
1479 ****************/
1480
1481 static long
1482 cuserid_internal(args,result,funct)
1483 ptr_psi_term args[],result,funct;
1484 {
1485 // char name[L_cuserid+1];
1486 // if (*cuserid(name) == '\0') return FALSE;
1487 // else {
1488 push_goal(unify,result,stack_string(getlogin()),NULL);
1489 return TRUE;
1490 // }
1491 }
1492
1493 static long
1494 c_cuserid()
1495 {
1496 return call_primitive(cuserid_internal,0,NULL,0);
1497 }
1498
1499 #ifndef MAXHOSTNAMELEN
1500 #include <sys/param.h>
1501 #endif
1502
1503 static long
1504 gethostname_internal(args,result,funct)
1505 ptr_psi_term args[],result,funct;
1506 {
1507 char name_loc[MAXHOSTNAMELEN+1];
1508 if (gethostname(name_loc,MAXHOSTNAMELEN+1) == 0) {
1509 push_goal(unify,result,stack_string(name_loc),NULL);
1510 return TRUE;
1511 }
1512 else return FALSE;
1513 }
1514
1515 static long
1516 c_gethostname()
1517 {
1518 return call_primitive(gethostname_internal,0,NULL,0);
1519 }
1520
1521 /* LAZY PROJECT
1522 ***************/
1523
1524 static long
1525 lazy_project_internal(args,result,funct)
1526 ptr_psi_term args[],result,funct;
1527 {
1528 ptr_node n;
1529 char buffer_loc[100];
1530 if (args[1]->type == top) {
1531 residuate(args[0]);
1532 residuate(args[1]);
1533 return TRUE;
1534 }
1535 if (sub_type(args[1]->type,integer) && args[1]->value_3)
1536 snprintf(buffer_loc,100,"%ld",(long)*(REAL*)args[1]->value_3);
1537 else if (sub_type(args[1]->type,quoted_string) && args[1]->value_3)
1538 strcpy(buffer_loc,(char*)args[1]->value_3);
1539 else
1540 strcpy(buffer_loc,args[1]->type->keyword->symbol);
1541 n=find(FEATCMP,buffer_loc,args[0]->attr_list);
1542 if (n) push_goal(unify,(ptr_psi_term)n->data,result,NULL);
1543 /* this is all bullshit because projection should residuate
1544 on its 2nd arg until it becomes value. In particular, think
1545 of using `int' as a feature when it is clear that `int' may
1546 subsequently be refined to a particular integer. */
1547 else residuate(args[0]);
1548 return TRUE;
1549 }
1550
1551 static long
1552 c_lazy_project()
1553 {
1554 psi_arg args[2];
1555 SETARG(args,0,"1",top,REQUIRED|NOVALUE);
1556 SETARG(args,1,"2",top,REQUIRED|NOVALUE);
1557 return call_primitive(lazy_project_internal,NARGS(args),args,0);
1558 }
1559
1560 /* WAIT_ON_FEATURE
1561 ******************/
1562
1563 static long
1564 wait_on_feature_internal(args,result,funct)
1565 ptr_psi_term args[],result,funct;
1566 {
1567 char buffer_loc[100];
1568 if (args[1]->type == top) {
1569 residuate(args[0]);
1570 residuate(args[1]);
1571 return TRUE;
1572 }
1573 if (sub_type(args[1]->type,integer) && args[1]->value_3)
1574 snprintf(buffer_loc,100,"%ld",(long)*(REAL*)args[1]->value_3);
1575 else if (sub_type(args[1]->type,quoted_string) && args[1]->value_3)
1576 strcpy(buffer_loc,(char*)args[1]->value_3);
1577 else
1578 strcpy(buffer_loc,args[1]->type->keyword->symbol);
1579 if (find(FEATCMP,buffer_loc,args[0]->attr_list))
1580 push_goal(prove,args[2],(ptr_psi_term)DEFRULES,NULL);
1581 /* this is all bullshit because projection should residuate
1582 on its 2nd arg until it becomes value. In particular, think
1583 of using `int' as a feature when it is clear that `int' may
1584 subsequently be refined to a particular integer. */
1585 else residuate(args[0]);
1586 return TRUE;
1587 }
1588
1589 static long
1590 c_wait_on_feature()
1591 {
1592 psi_arg args[3];
1593 SETARG(args,0,"1",top,MANDATORY|NOVALUE);
1594 SETARG(args,1,"2",top,MANDATORY|NOVALUE);
1595 SETARG(args,2,"3",top,MANDATORY|NOVALUE|UNEVALED);
1596 return call_primitive(wait_on_feature_internal,NARGS(args),args,0);
1597 }
1598
1599 static long
1600 my_wait_on_feature_internal(args,result,funct)
1601 ptr_psi_term args[],result,funct;
1602 {
1603 char buffer_loc[100];
1604 if (args[1]->type == top) {
1605 residuate(args[0]);
1606 residuate(args[1]);
1607 return TRUE;
1608 }
1609 if (sub_type(args[1]->type,integer) && args[1]->value_3)
1610 snprintf(buffer_loc,100,"%ld",(long)*(REAL*)args[1]->value_3);
1611 else if (sub_type(args[1]->type,quoted_string) && args[1]->value_3)
1612 strcpy(buffer_loc,(char*)args[1]->value_3);
1613 else
1614 strcpy(buffer_loc,args[1]->type->keyword->symbol);
1615 if (find(FEATCMP,buffer_loc,args[0]->attr_list)) {
1616 unify_bool_result(result,TRUE);
1617 push_goal(prove,args[2],(ptr_psi_term)DEFRULES,NULL);
1618 }
1619 /* this is all bullshit because projection should residuate
1620 on its 2nd arg until it becomes value. In particular, think
1621 of using `int' as a feature when it is clear that `int' may
1622 subsequently be refined to a particular integer. */
1623 else residuate(args[0]);
1624 return TRUE;
1625 }
1626
1627 static long
1628 c_my_wait_on_feature()
1629 {
1630 psi_arg args[3];
1631 SETARG(args,0,"1",top,MANDATORY|NOVALUE);
1632 SETARG(args,1,"2",top,MANDATORY|NOVALUE);
1633 SETARG(args,2,"3",top,MANDATORY|NOVALUE|UNEVALED);
1634 return call_primitive(my_wait_on_feature_internal,NARGS(args),args,0);
1635 }
1636
1637 /* CALL_ONCE
1638 ************/
1639 /*
1640 call_once(G) -> T | G,!,T=lf_true;T=lf_false.
1641 */
1642
1643 static long
1644 call_once_internal(args,result,funct)
1645 ptr_psi_term args[],result,funct;
1646 {
1647 ptr_psi_term value;
1648 ptr_choice_point cutpt = choice_stack;
1649 resid_aim=NULL;
1650 value = stack_psi_term(4);
1651 value->type = lf_false;
1652 push_choice_point(unify,result,value,NULL);
1653 value = stack_psi_term(4);
1654 value->type = lf_true;
1655 push_goal(unify,result,value,NULL);
1656 push_goal(general_cut,(ptr_psi_term)cutpt,NULL,NULL);
1657 push_goal(prove,args[0],(ptr_psi_term)DEFRULES,NULL);
1658 return TRUE;
1659 }
1660
1661 static long
1662 c_call_once()
1663 {
1664 psi_arg args[1];
1665 SETARG(args,0,"1",top,MANDATORY|NOVALUE|UNEVALED);
1666 return call_primitive(call_once_internal,NARGS(args),args,0);
1667 }
1668
1669 static long
1670 apply1_internal(args,result,funct)
1671 ptr_psi_term args[],result,funct;
1672 {
1673 long success=TRUE;
1674 if (args[0]->type==top) residuate(args[0]);
1675 else if (args[0]->type->type_def!=(def_type)function_it) {
1676 Errorline("1st arg not a function in %P.\n",funct);
1677 success=FALSE;
1678 }
1679 else {
1680 // char buffer_loc[1000];
1681 char * feat;
1682 ptr_psi_term fun;
1683 if (sub_type(args[1]->type,integer) && args[1]->value_3)
1684 feat = get_numeric_feature((long)*(REAL*)args[1]->value_3);
1685 else if (sub_type(args[1]->type,quoted_string) && args[1]->value_3)
1686 feat = (char *)args[1]->value_3;
1687 else
1688 feat = (char *)heap_copy_string(args[1]->type->keyword->symbol);
1689 clear_copy();
1690 fun=distinct_copy(args[0]);
1691 (void)stack_insert(FEATCMP,(char *)feat,&(fun->attr_list),(GENERIC)args[2]);
1692 push_goal(eval,fun,result,(GENERIC)fun->type->rule);
1693 }
1694 return success;
1695 }
1696
1697 static long
1698 c_apply1()
1699 {
1700 psi_arg args[3];
1701 SETARG(args,0,"1",top,REQUIRED|NOVALUE);
1702 SETARG(args,1,"2",top,REQUIRED|NOVALUE);
1703 SETARG(args,2,"3",top,REQUIRED|NOVALUE);
1704 return call_primitive(apply1_internal,NARGS(args),args,0);
1705 }
1706
1707 static long
1708 getpid_internal(args,result,funct)
1709 ptr_psi_term args[],result,funct;
1710 {
1711 return unify_real_result(result,(REAL)getpid());
1712 }
1713
1714 static long
1715 c_getpid()
1716 {
1717 return call_primitive(getpid_internal,0,0,0);
1718 }
1719
1720 /********************************************************************
1721 INITIALIZATION FUNCTIONS
1722 *******************************************************************/
1723
1724
1725 void
1726 make_sys_type_links()
1727 {
1728 #ifdef LIFE_NDBM
1729 make_ndbm_type_links();
1730 #endif
1731 make_type_link(sys_bitvector ,sys_bytedata);
1732 make_type_link(sys_regexp ,sys_bytedata);
1733 make_type_link(sys_stream ,sys_bytedata);
1734 make_type_link(sys_file_stream ,sys_stream);
1735 make_type_link(sys_socket_stream,sys_stream);
1736 make_type_link(sys_bytedata ,built_in); /* DENYS: BYTEDATA */
1737 }
1738
1739 void
1740 check_sys_definitions()
1741 {
1742 check_definition(&sys_bytedata); /* DENYS: BYTEDATA */
1743 check_definition(&sys_bitvector);
1744 check_definition(&sys_regexp);
1745 check_definition(&sys_stream);
1746 check_definition(&sys_file_stream);
1747 check_definition(&sys_socket_stream);
1748 check_definition(&sys_process_no_children);
1749 check_definition(&sys_process_exited);
1750 check_definition(&sys_process_signaled);
1751 check_definition(&sys_process_stopped);
1752 check_definition(&sys_process_continued);
1753 #ifdef LIFE_NDBM
1754 check_ndbm_definitions();
1755 #endif
1756 }
1757
1758
1759 void
1760 insert_sys_builtins()
1761 {
1762 ptr_module curmod = current_module;
1763 (void)set_current_module(sys_module);
1764
1765 sys_bytedata =update_symbol(sys_module,"bytedata"); /* DENYS: BYTEDATA */
1766 sys_bitvector =update_symbol(sys_module,"bitvector");
1767 sys_regexp =update_symbol(sys_module,"regexp");
1768 sys_stream =update_symbol(sys_module,"stream");
1769 sys_file_stream =update_symbol(sys_module,"file_stream");
1770 sys_socket_stream =update_symbol(sys_module,"socket_stream");
1771 sys_process_no_children=update_symbol(sys_module,"process_no_children");
1772 sys_process_exited =update_symbol(sys_module,"process_exited");
1773 sys_process_signaled =update_symbol(sys_module,"process_signaled");
1774 sys_process_stopped =update_symbol(sys_module,"process_stopped");
1775 sys_process_continued =update_symbol(sys_module,"process_continued");
1776
1777 /* DENYS: BYTEDATA */
1778 /* purely for illustration
1779 new_built_in(sys_module,"string_to_bytedata",(def_type)function_it,c_string_to_bytedata);
1780 new_built_in(sys_module,"bytedata_to_string",(def_type)function_it,c_bytedata_to_string);
1781 */
1782 new_built_in(sys_module,"make_bitvector" ,(def_type)function_it ,c_make_bitvector);
1783 new_built_in(sys_module,"bitvector_and" ,(def_type)function_it ,c_bitvector_and);
1784 new_built_in(sys_module,"bitvector_or" ,(def_type)function_it ,c_bitvector_or);
1785 new_built_in(sys_module,"bitvector_xor" ,(def_type)function_it ,c_bitvector_xor);
1786 new_built_in(sys_module,"bitvector_not" ,(def_type)function_it ,c_bitvector_not);
1787 new_built_in(sys_module,"bitvector_count" ,(def_type)function_it ,c_bitvector_count);
1788 new_built_in(sys_module,"bitvector_get" ,(def_type)function_it ,c_bitvector_get);
1789 new_built_in(sys_module,"bitvector_set" ,(def_type)function_it ,c_bitvector_set);
1790 new_built_in(sys_module,"bitvector_clear" ,(def_type)function_it ,c_bitvector_clear);
1791 new_built_in(sys_module,"regexp_compile" ,(def_type)function_it ,c_regexp_compile);
1792 new_built_in(sys_module,"regexp_execute" ,(def_type)function_it ,c_regexp_execute);
1793 new_built_in(sys_module,"int2stream" ,(def_type)function_it ,c_int2stream);
1794 new_built_in(sys_module,"fopen" ,(def_type)function_it ,c_fopen);
1795 new_built_in(sys_module,"fclose" ,(def_type)function_it ,c_fclose);
1796 new_built_in(sys_module,"get_buffer" ,(def_type)function_it ,c_get_buffer);
1797 new_built_in(sys_module,"get_record" ,(def_type)function_it ,c_get_record);
1798 new_built_in(sys_module,"get_code" ,(def_type)function_it ,c_get_code);
1799 new_built_in(sys_module,"ftell" ,(def_type)function_it ,c_ftell);
1800 new_built_in(sys_module,"fseek" ,(def_type)predicate,c_fseek);
1801 new_built_in(sys_module,"socket" ,(def_type)function_it ,c_socket);
1802 new_built_in(sys_module,"bind" ,(def_type)predicate,c_bind);
1803 new_built_in(sys_module,"connect" ,(def_type)predicate,c_connect);
1804 new_built_in(sys_module,"fwrite" ,(def_type)predicate,c_fwrite);
1805 new_built_in(sys_module,"fflush" ,(def_type)predicate,c_fflush);
1806 new_built_in(sys_module,"listen" ,(def_type)predicate,c_listen);
1807 new_built_in(sys_module,"accept" ,(def_type)function_it ,c_accept);
1808 new_built_in(sys_module,"errno" ,(def_type)function_it ,c_errno);
1809 new_built_in(sys_module,"errmsg" ,(def_type)function_it ,c_errmsg);
1810 new_built_in(sys_module,"import_symbol" ,(def_type)predicate,c_import_symbol);
1811 new_built_in(sys_module,"fork" ,(def_type)function_it ,c_fork);
1812 new_built_in(sys_module,"wait" ,(def_type)function_it ,c_wait);
1813 new_built_in(sys_module,"waitpid" ,(def_type)function_it ,c_waitpid);
1814 new_built_in(sys_module,"kill" ,(def_type)predicate,c_kill);
1815 new_built_in(sys_module,"cuserid" ,(def_type)function_it ,c_cuserid);
1816 new_built_in(sys_module,"gethostname" ,(def_type)function_it ,c_gethostname);
1817 new_built_in(sys_module,"lazy_project" ,(def_type)function_it ,c_lazy_project);
1818 new_built_in(sys_module,"wait_on_feature" ,(def_type)predicate,c_wait_on_feature);
1819 new_built_in(sys_module,"my_wait_on_feature" ,(def_type)function_it ,c_my_wait_on_feature);
1820 new_built_in(sys_module,"apply1" ,(def_type)function_it ,c_apply1);
1821 new_built_in(sys_module,"getpid" ,(def_type)function_it ,c_getpid);
1822 new_built_in(sys_module,"stream2sys_stream" ,(def_type)function_it ,c_stream2sys_stream);
1823 new_built_in(sys_module,"sys_stream2stream" ,(def_type)function_it ,c_sys_stream2stream);
1824 #ifdef LIFE_DBM
1825 insert_dbm_builtins();
1826 #endif
1827 #ifdef LIFE_NDBM
1828 insert_ndbm_builtins();
1829 #endif
1830 (void)set_current_module(bi_module);
1831 new_built_in(bi_module ,"call_once" ,(def_type)function_it ,c_call_once);
1832 (void)set_current_module(curmod);
1833 }
BV_OR
#define BV_OR
Definition: sys.c:163
prove
#define prove
Definition: def_const.h:273
bitvector_unop
static long bitvector_unop(long op)
Definition: sys.c:299
new_built_in
void new_built_in(ptr_module m, char *s, def_type t, long(*r)())
Definition: built_ins.c:5054
text_buffer_cmp
char * text_buffer_cmp(struct text_buffer *buf, int idx, char *str)
Definition: sys.c:748
wl_goal::aaaa_1
ptr_psi_term aaaa_1
Definition: def_struct.h:224
hash_lookup
ptr_keyword hash_lookup(ptr_hash_table table, char *symbol)
Definition: hash_table.c:133
insert_sys_builtins
void insert_sys_builtins()
Definition: sys.c:1760
BV_NOT
#define BV_NOT
Definition: sys.c:243
predicate
#define predicate
Definition: def_const.h:361
function_it
#define function_it
Definition: def_const.h:362
sys_regexp
ptr_definition sys_regexp
Definition: def_glob.h:131
c_make_bitvector
static long c_make_bitvector()
Definition: sys.c:155
c_bitvector_not
static long c_bitvector_not()
Definition: sys.c:308
c_wait
static long c_wait()
Definition: sys.c:1437
MANDATORY
#define MANDATORY
Definition: def_const.h:219
make_sys_type_links
void make_sys_type_links()
Definition: sys.c:1726
BV_CLEAR
#define BV_CLEAR
Definition: sys.c:321
lazy_project_internal
static long lazy_project_internal(args, result, funct)
Definition: sys.c:1525
FEATCMP
#define FEATCMP
Definition: def_const.h:257
clear_copy
void clear_copy()
Definition: copy.c:52
residuate
void residuate(ptr_psi_term t)
Definition: lefun.c:113
wait_internal
static long wait_internal(args, result, funct)
Definition: sys.c:1428
gethostname_internal
static long gethostname_internal(args, result, funct)
Definition: sys.c:1504
get_code_internal
static long get_code_internal(args, result, funct)
Definition: sys.c:892
wl_choice_point
Definition: def_struct.h:231
wl_keyword::combined_name
char * combined_name
Definition: def_struct.h:92
bitvector_bit_internal
static long bitvector_bit_internal(args, result, funct, GENERIC op)
Definition: sys.c:361
text_buffer::data
char data[TEXTBUFSIZE]
Definition: def_struct.h:401
call_primitive
long call_primitive(long(*fun)(), int num, argi, GENERIC info)
Definition: sys.c:12
regerror
void regerror(char *s)
Definition: sys.c:404
current_module
ptr_module current_module
Definition: def_glob.h:161
bitvector_bit_code
static long bitvector_bit_code(unsigned long *bv1, long idx, ptr_psi_term result, int op, ptr_psi_term funct)
Definition: sys.c:324
c_accept
static long c_accept()
Definition: sys.c:1212
my_wait_on_feature_internal
static long my_wait_on_feature_internal(args, result, funct)
Definition: sys.c:1600
SETARG
#define SETARG(args, i, the_feature, the_type, the_options)
Definition: def_macro.h:163
push_choice_point
void push_choice_point(goals t, ptr_psi_term a, ptr_psi_term b, GENERIC c)
Definition: login.c:591
push_goal
void push_goal(goals t, ptr_psi_term a, ptr_psi_term b, GENERIC c)
Definition: login.c:555
stream
ptr_definition stream
Definition: def_glob.h:103
c_fwrite
static long c_fwrite()
Definition: sys.c:664
int2stream_internal
static long int2stream_internal(args, result, funct)
Definition: sys.c:582
text_buffer_free
void text_buffer_free(struct text_buffer *buf)
Definition: sys.c:795
c_call_once
static long c_call_once()
Definition: sys.c:1662
unify_pterm_result
static long unify_pterm_result(ptr_psi_term t, ptr_definition sym, lst, int n)
Definition: sys.c:1339
unify_bool_result
void unify_bool_result(ptr_psi_term t, long v)
Definition: built_ins.c:329
make_module_token
char * make_module_token(ptr_module module, char *str)
Definition: modules.c:185
kill_internal
static long kill_internal(args, result, funct)
Definition: sys.c:1462
two
char * two
Definition: def_glob.h:251
BV_SET
#define BV_SET
Definition: sys.c:320
undef
#define undef
Definition: def_const.h:360
c_stream2sys_stream
static long c_stream2sys_stream()
Definition: sys.c:974
c_ftell
static long c_ftell()
Definition: sys.c:924
bitvector_binop_code
static long bitvector_binop_code(unsigned long *bv1, unsigned long *bv2, ptr_psi_term result, GENERIC op)
Definition: sys.c:167
wl_module
Definition: def_struct.h:74
general_cut
#define general_cut
Definition: def_const.h:282
c_regexp_compile
static long c_regexp_compile()
Definition: sys.c:453
c_int2stream
static long c_int2stream()
Definition: sys.c:598
wl_keyword::definition
ptr_definition definition
Definition: def_struct.h:96
wl_definition::type_def
def_type type_def
Definition: def_struct.h:133
c_kill
static long c_kill()
Definition: sys.c:1470
defs.h
text_buffer
Definition: def_struct.h:398
sys_file_stream
ptr_definition sys_file_stream
Definition: def_glob.h:133
wl_psi_term
Definition: def_struct.h:161
fileptr2stream
ptr_psi_term fileptr2stream(FILE *fp, ptr_definition typ)
Definition: sys.c:571
BV_XOR
#define BV_XOR
Definition: sys.c:164
c_fseek
static long c_fseek()
Definition: sys.c:955
DEFRULES
#define DEFRULES
Definition: def_const.h:138
fwrite_internal
static long fwrite_internal(args, result, funct)
Definition: sys.c:650
c_get_record
static long c_get_record()
Definition: sys.c:883
a_stream::fp
FILE * fp
Definition: sys.c:563
c_abort
long c_abort()
Definition: built_ins.c:2117
bitvector_unop_internal
static long bitvector_unop_internal(args, result, funct, GENERIC op)
Definition: sys.c:290
sys_stream
ptr_definition sys_stream
Definition: def_glob.h:132
psi_feature::value_str
ptr_psi_term value_str
Definition: sys.c:1333
fopen_internal
static long fopen_internal(args, result, funct)
Definition: sys.c:607
wl_module::symbol_table
ptr_hash_table symbol_table
Definition: def_struct.h:79
c_getpid
static long c_getpid()
Definition: sys.c:1715
c_get_code
static long c_get_code()
Definition: sys.c:903
c_bitvector_set
static long c_bitvector_set()
Definition: sys.c:387
c_fclose
static long c_fclose()
Definition: sys.c:642
wl_node::data
GENERIC data
Definition: def_struct.h:185
top
ptr_definition top
Definition: def_glob.h:106
curry
void curry()
Definition: lefun.c:157
NULL
#define NULL
Definition: def_const.h:203
regexp_compile_internal
static long regexp_compile_internal(args, result, funct)
Definition: sys.c:416
waitpid_internal
static long waitpid_internal(args, result, funct)
Definition: sys.c:1443
errno_internal
static long errno_internal(args, result, funct)
Definition: sys.c:1223
three
char * three
Definition: def_glob.h:252
wl_keyword::symbol
char * symbol
Definition: def_struct.h:91
resid_aim
ptr_goal resid_aim
Definition: def_glob.h:220
overlap_type
long overlap_type(ptr_definition t1, ptr_definition t2)
Definition: types.c:1486
bitvector_bit
static long bitvector_bit(long op)
Definition: sys.c:371
REAL
#define REAL
Definition: def_const.h:72
psi_arg
Definition: def_struct.h:362
update_symbol
ptr_definition update_symbol(ptr_module module, char *symbol)
Definition: modules.c:264
psi_feature
Definition: sys.c:1331
get_buffer_internal
static long get_buffer_internal(args, result, funct)
Definition: sys.c:692
get_numeric_feature
char * get_numeric_feature(long n)
Definition: sys.c:1360
JUSTFAIL
#define JUSTFAIL
Definition: def_const.h:217
eval
#define eval
Definition: def_const.h:278
FP_OUTPUT
#define FP_OUTPUT
Definition: sys.c:560
c_apply1
static long c_apply1()
Definition: sys.c:1698
c_bitvector_xor
static long c_bitvector_xor()
Definition: sys.c:238
sub_type
long sub_type(ptr_definition t1, ptr_definition t2)
Definition: types.c:1544
c_fflush
static long c_fflush()
Definition: sys.c:684
getpid_internal
static long getpid_internal(args, result, funct)
Definition: sys.c:1708
c_fopen
static long c_fopen()
Definition: sys.c:623
ptr_stream
struct a_stream * ptr_stream
bitvector_binop
static long bitvector_binop(long op)
Definition: sys.c:216
text_buffer::top
int top
Definition: def_struct.h:400
Errorline
void Errorline(char *format,...)
Definition: error.c:414
c_connect
static long c_connect()
Definition: sys.c:1157
heap_copy_string
char * heap_copy_string(char *s)
Definition: trees.c:147
bitvector_binop_internal
static long bitvector_binop_internal(ptr_psi_term *args, ptr_psi_term result, ptr_psi_term funct, GENERIC op)
Definition: sys.c:206
socket_internal
static long socket_internal(args, result, funct)
Definition: sys.c:1012
unify_wait_result
static long unify_wait_result(ptr_psi_term result, pid_t id, int status)
Definition: sys.c:1384
FP_NONE
#define FP_NONE
Definition: sys.c:558
c_listen
static long c_listen()
Definition: sys.c:1179
SETFEATURE
#define SETFEATURE(lst, n, nam, val)
Definition: sys.c:1336
stack_pair
ptr_psi_term stack_pair(ptr_psi_term left, ptr_psi_term right)
Definition: built_ins.c:67
c_import_symbol
static long c_import_symbol()
Definition: sys.c:1305
c_waitpid
static long c_waitpid()
Definition: sys.c:1453
stack_insert
ptr_node stack_insert(long comp, char *keystr, ptr_node *tree, GENERIC info)
Definition: trees.c:291
BV_GET
#define BV_GET
Definition: sys.c:319
deref_ptr
#define deref_ptr(P)
Definition: def_macro.h:95
errmsg_internal
static long errmsg_internal(args, result, funct)
Definition: sys.c:1241
BYTEDATA_DATA
#define BYTEDATA_DATA(X)
Definition: sys.c:128
accept_internal
static long accept_internal(args, result, funct)
Definition: sys.c:1188
sys_process_signaled
ptr_definition sys_process_signaled
Definition: sys.c:1379
check_sys_definitions
void check_sys_definitions()
Definition: sys.c:1740
TEXTBUFSIZE
#define TEXTBUFSIZE
Definition: def_struct.h:396
psi_arg::type
ptr_definition type
Definition: def_struct.h:364
REQUIRED
#define REQUIRED
Definition: def_const.h:215
hash_insert
void hash_insert(ptr_hash_table table, char *symbol, ptr_keyword keyword)
Definition: hash_table.c:155
fflush_internal
static long fflush_internal(args, result, funct)
Definition: sys.c:673
ftell_internal
static long ftell_internal(args, result, funct)
Definition: sys.c:911
distinct_copy
ptr_psi_term distinct_copy(ptr_psi_term t)
Definition: copy.c:358
TRUE
#define TRUE
Definition: def_const.h:127
sys_bitvector
ptr_definition sys_bitvector
Definition: def_glob.h:130
c_fork
static long c_fork()
Definition: sys.c:1326
sys_stream2stream_internal
static long sys_stream2stream_internal(args, result, funct)
Definition: sys.c:982
is_ipaddr
int is_ipaddr(char *s)
Definition: sys.c:1068
built_in
ptr_definition built_in
Definition: def_glob.h:75
make_type_link
void make_type_link(ptr_definition t1, ptr_definition t2)
Definition: types.c:848
cuserid_internal
static long cuserid_internal(args, result, funct)
Definition: sys.c:1482
integer
ptr_definition integer
Definition: def_glob.h:93
lf_true
ptr_definition lf_true
Definition: def_glob.h:107
stack_int
ptr_psi_term stack_int(long n)
Definition: built_ins.c:87
wl_definition::rule
ptr_pair_list rule
Definition: def_struct.h:126
FALSE
#define FALSE
Definition: def_const.h:128
deref
#define deref(P)
Definition: def_macro.h:142
bitvector_unop_code
static long bitvector_unop_code(unsigned long *bv1, ptr_psi_term result, int op)
Definition: sys.c:247
text_buffer_next
int text_buffer_next(struct text_buffer *buf, int idx, char c, struct text_buffer **rbuf, int *ridx)
Definition: sys.c:724
quoted_string
ptr_definition quoted_string
Definition: def_glob.h:101
wl_keyword
Definition: def_struct.h:89
sys_process_stopped
ptr_definition sys_process_stopped
Definition: sys.c:1380
stack_psi_term
ptr_psi_term stack_psi_term(long stat)
Definition: lefun.c:15
lf_false
ptr_definition lf_false
Definition: def_glob.h:89
wl_psi_term::value_3
GENERIC value_3
Definition: def_struct.h:170
BV_AND
#define BV_AND
Definition: sys.c:162
sys_process_continued
ptr_definition sys_process_continued
Definition: sys.c:1381
c_bitvector_count
static long c_bitvector_count()
Definition: sys.c:314
aim
ptr_goal aim
Definition: def_glob.h:49
import_symbol_internal
static long import_symbol_internal(args, result, funct)
Definition: sys.c:1269
one
char * one
Definition: def_glob.h:250
insert_dbm_builtins
void insert_dbm_builtins()
c_wait_on_feature
static long c_wait_on_feature()
Definition: sys.c:1590
FP_INPUT
#define FP_INPUT
Definition: sys.c:559
c_bind
static long c_bind()
Definition: sys.c:1146
unify
#define unify
Definition: def_const.h:274
make_bitvector_internal
static long make_bitvector_internal(args, result, funct)
Definition: sys.c:138
find
ptr_node find(long comp, char *keystr, ptr_node tree)
Definition: trees.c:341
c_errno
static long c_errno()
Definition: sys.c:1231
a_stream
Definition: sys.c:562
fclose_internal
static long fclose_internal(args, result, funct)
Definition: sys.c:632
wl_definition
Definition: def_struct.h:121
c_regexp_execute
static long c_regexp_execute()
Definition: sys.c:538
sys_module
ptr_module sys_module
Definition: def_glob.h:162
c_cuserid
static long c_cuserid()
Definition: sys.c:1494
wl_keyword::module
ptr_module module
Definition: def_struct.h:90
fork_internal
static long fork_internal(args, result, funct)
Definition: sys.c:1317
check_definition
void check_definition(ptr_definition *d)
Definition: memory.c:612
c_bitvector_or
static long c_bitvector_or()
Definition: sys.c:232
FP_PREPARE
#define FP_PREPARE(s, OP)
Definition: sys.c:567
c_socket
static long c_socket()
Definition: sys.c:1059
sys_bytedata
ptr_definition sys_bytedata
Definition: def_glob.h:336
NOVALUE
#define NOVALUE
Definition: def_const.h:220
sys_socket_stream
ptr_definition sys_socket_stream
Definition: def_glob.h:134
sys_process_exited
ptr_definition sys_process_exited
Definition: sys.c:1378
ptr_psi_term
struct wl_psi_term * ptr_psi_term
Definition: def_struct.h:34
a_stream::op
int op
Definition: sys.c:564
SEEK_SET
#define SEEK_SET
Definition: sys.c:932
unify_real_result
long unify_real_result(ptr_psi_term t, REAL v)
Definition: built_ins.c:371
wait_on_feature_internal
static long wait_on_feature_internal(args, result, funct)
Definition: sys.c:1564
c_bitvector_and
static long c_bitvector_and()
Definition: sys.c:226
get_record_internal
static long get_record_internal(args, result, funct)
Definition: sys.c:807
make_bytedata
static ptr_psi_term make_bytedata(ptr_definition sort, unsigned long bytes)
Definition: sys.c:113
NARGS
#define NARGS(args)
Definition: def_macro.h:169
wl_keyword::private_feature
int private_feature
Definition: def_struct.h:95
c_lazy_project
static long c_lazy_project()
Definition: sys.c:1552
c_my_wait_on_feature
static long c_my_wait_on_feature()
Definition: sys.c:1628
c_bitvector_get
static long c_bitvector_get()
Definition: sys.c:381
c_bitvector_clear
static long c_bitvector_clear()
Definition: sys.c:393
psi_feature::name_str
char * name_str
Definition: sys.c:1332
bi_module
ptr_module bi_module
Definition: def_glob.h:155
wl_keyword::public
int public
Definition: def_struct.h:94
wl_node
Definition: def_struct.h:181
wl_psi_term::type
ptr_definition type
Definition: def_struct.h:165
wl_goal::bbbb_1
ptr_psi_term bbbb_1
Definition: def_struct.h:225
apply1_internal
static long apply1_internal(args, result, funct)
Definition: sys.c:1670
c_sys_stream2stream
static long c_sys_stream2stream()
Definition: sys.c:994
GENERIC
unsigned long * GENERIC
Definition: def_struct.h:17
stack_string
ptr_psi_term stack_string(char *s)
Definition: built_ins.c:102
OPTIONAL
#define OPTIONAL
Definition: def_const.h:214
listen_internal
static long listen_internal(args, result, funct)
Definition: sys.c:1168
stream2sys_stream_internal
static long stream2sys_stream_internal(args, result, funct)
Definition: sys.c:965
text_buffer::next
struct text_buffer * next
Definition: def_struct.h:399
HEAP_ALLOC
#define HEAP_ALLOC(A)
Definition: def_macro.h:15
bind_or_connect_internal
static long bind_or_connect_internal(args, result, funct, void *info)
Definition: sys.c:1079
c_gethostname
static long c_gethostname()
Definition: sys.c:1516
BV_COUNT
#define BV_COUNT
Definition: sys.c:244
wl_psi_term::attr_list
ptr_node attr_list
Definition: def_struct.h:171
set_current_module
ptr_module set_current_module(ptr_module module)
Definition: modules.c:95
c_get_buffer
static long c_get_buffer()
Definition: sys.c:710
ARGNN
#define ARGNN
Definition: def_const.h:347
call_once_internal
static long call_once_internal(args, result, funct)
Definition: sys.c:1644
sys_process_no_children
ptr_definition sys_process_no_children
Definition: sys.c:1377
heap_alloc
GENERIC heap_alloc(long s)
Definition: memory.c:1518
POLYTYPE
#define POLYTYPE
Definition: def_const.h:218
stack_insert_copystr
void stack_insert_copystr(char *keystr, ptr_node *tree, GENERIC info)
Definition: trees.c:260
choice_stack
ptr_choice_point choice_stack
Definition: def_glob.h:51
c_errmsg
static long c_errmsg()
Definition: sys.c:1253
regexp_execute_internal
static long regexp_execute_internal(args, result, funct)
Definition: sys.c:469
fseek_internal
static long fseek_internal(args, result, funct)
Definition: sys.c:942
UNEVALED
#define UNEVALED
Definition: def_const.h:216
text_buffer_push
void text_buffer_push(struct text_buffer **buf, char c)
Definition: sys.c:773