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