unixcall.c
Go to the documentation of this file.
1 /****************************************************************/
2 /* unixcall.c
3 /* 1986-Jul-6 original for Ustation
4 /* 1986-Dec process id's, file changes, syserrlist
5 /* 1987-Feb dup,isatty
6 /* 1987-Apr getwd,stat,time
7 /* 1988-Jan,Feb socket, select
8 /* 1988-Dec ioctl
9 /* 1990-Mar VxWorks
10 /* Copyright(c) 1988 MATSUI Toshihiro, Electrotechnical Laboratory.
11 /****************************************************************/
12 
13 static char *rcsid="@(#)$Id$";
14 
15 /* SunOS's gettimeofday used to accept only one argument.
16 #ifdef Solaris2
17 #define _SVID_GETTOD
18 #endif
19 */
20 
21 #include "eus.h"
22 
23 #if vxworks
24 #define NSIG NUM_SIGNALS
25 #define SIG_DFL 0
26 #include <sigLib.h>
27 #include <socket.h>
28 #include <in.h>
29 #else
30 #include <sys/types.h>
31 #include <sys/times.h>
32 #include <sys/stat.h>
33 #include <signal.h>
34 #include <sys/ioctl.h>
35 #include <time.h>
36 #include <sys/time.h>
37 #include <sys/socket.h>
38 #include <sys/un.h>
39 #include <netinet/in.h>
40 #include <netdb.h>
41 #include <sys/mman.h>
42 #include <string.h>
43 #include <unistd.h> /* for lseek */
44 #endif
45 
46 /*SONY/news doesn't have message queu ipc facilities*/
47 #if !vxworks
48 #include <sys/ipc.h>
49 #include <sys/msg.h>
50 #endif
51 
52 #if SunOS4_1 || (mips && !IRIX && !IRIX6)
53 /* Sun likes to change ioccom constants frequently. */
54 #define IOC_VOID _IOC_VOID
55 #define IOC_IN _IOC_IN
56 #define IOC_OUT _IOC_OUT
57 #define IOC_INOUT _IOC_INOUT
58 #endif
59 
60 #if Linux
61 #define IOC_VOID 0
62 #endif
63 
64 #if Solaris2 || Linux || alpha || Cygwin
65 #include <errno.h>
66 #include <dirent.h>
67 #else
68 extern int errno;
69 #endif
70 
71 #if Linux
72 #define IOC_VOID 0
73 #endif
74 
75 
76 #if alpha
77 #include <sys/utsname.h>
78 #include <sys/types.h>
79 #include <sys/ipc.h>
80 #include <sys/msg.h>
81 #endif
82 
83 #if system5 || Linux || Cygwin
84 #include <sys/utsname.h>
85 #endif
86 
87 #include <time.h>
88 //extern char *tzname[2];
89 #if !Cygwin /* extern timezone */
90 extern time_t timezone, altzone; /*long*/
91 #endif
92 extern int daylight;
93 
94 extern pointer eussigvec[NSIG];
95 
97 
98 
99 /***************** times and status *****************/
100 
101 #if !vxworks
102 pointer PTIMES(ctx,n,argv)
103 register context *ctx;
104 int n;
105 pointer argv[];
106 { struct tms buffer;
107  register pointer t;
108  long et;
109  ckarg(0);
110  GC_REGION(et=times(&buffer););
111  t=cons(ctx,makeint(buffer.tms_cstime),NIL);
112  t=cons(ctx,makeint(buffer.tms_cutime),t);
113  t=cons(ctx,makeint(buffer.tms_stime),t);
114  t=cons(ctx,makeint(buffer.tms_utime),t);
115  t=cons(ctx,mkbigint(et),t);
116  return(t);}
117 
118 pointer RUNTIME(ctx,n,argv)
119 register context *ctx;
120 int n;
121 pointer argv[];
122 { struct tms buffer;
123  ckarg(0);
124  GC_REGION(times(&buffer););
125  return(makeint(buffer.tms_utime+buffer.tms_stime));}
126 
127 pointer LOCALTIME(ctx,n,argv)
128 register context *ctx;
129 int n;
130 pointer argv[];
131 { long clock;
132  struct tm *tms;
133  pointer timevec;
134  pointer *tv;
135  pointer tz0, tz1, tz;
136  struct tm res;
137 
138  if (n==1) clock=coerceintval(argv[0]);
139  else clock=time(0);
140  tms=localtime_r((time_t *)&clock,&res); /* localtime-->localtime_r */
141  timevec=makevector(C_VECTOR,10);
142  vpush(timevec);
143 
144 #ifdef Cygwin
145  if (getenv("TZ")==NULL) {
146  tzname[0]="UTC";
147  tzname[1]="UTC";
148  }
149 #endif
150 
151  tz0=makestring(tzname[0],strlen(tzname[0]));
152  vpush(tz0);
153  tz1=makestring(tzname[1],strlen(tzname[1]));
154  vpush(tz1);
155  tz=cons(ctx, tz1, NIL);
156  tz=cons(ctx, tz0, tz);
157  tv=timevec->c.vec.v;
158  tv[0]=makeint(tms->tm_sec);
159  tv[1]=makeint(tms->tm_min);
160  tv[2]=makeint(tms->tm_hour);
161  tv[3]=makeint(tms->tm_mday);
162  tv[4]=makeint(tms->tm_mon);
163  tv[5]=makeint(tms->tm_year);
164  tv[6]=makeint(tms->tm_wday);
165  tv[7]=makeint(tms->tm_yday);
166  tv[8]=(tms->tm_isdst>0)?T:NIL;
167  tv[9]=tz;
168  vpop(); vpop(); vpop();
169  return(timevec);}
170 
171 pointer ASCTIME(ctx,n,argv)
172 register context *ctx;
173 int n;
174 register pointer argv[];
175 { char *atp;
176  struct tm tms1, *tms;
177  pointer a=argv[0];
178  int i;
179 #define ASCTIME_STRLEN 30 /* at lease 26 chars */
180  char at[ASCTIME_STRLEN];
181 
182  ckarg(1);
183  if (isintvector(argv[0])) tms=(struct tm *)a->c.ivec.iv;
184  else if (isvector(a)) {
185  tms1.tm_sec=ckintval(a->c.vec.v[0]);
186  tms1.tm_min=ckintval(a->c.vec.v[1]);
187  tms1.tm_hour=ckintval(a->c.vec.v[2]);
188  tms1.tm_mday=ckintval(a->c.vec.v[3]);
189  tms1.tm_mon=ckintval(a->c.vec.v[4]);
190  tms1.tm_year=ckintval(a->c.vec.v[5]);
191  tms1.tm_wday=ckintval(a->c.vec.v[6]);
192  /* tms1.tm_yday=ckintval(a->c.vec.v[7]); */
193  tms1.tm_isdst=(a->c.vec.v[8]==NIL)?0:1;
194  tms= &tms1; }
195  else error(E_NOINTVECTOR);
196 #if defined(__USE_POSIX) || Cygwin || Linux
197  atp=asctime_r(tms,at); /* asctime --> asctime_r */
198 #else
199  atp=asctime_r(tms,at,ASCTIME_STRLEN); /* asctime --> asctime_r */
200 #endif
201  return(makestring(atp,strlen(atp)));}
202 
203 #if !Solaris2
204 #include <sys/resource.h>
205 pointer GETRUSAGE(ctx,n,argv)
206 register context *ctx;
207 int n; pointer argv[];
208 { register int who,i;
209  long rusage[18];
210  eusfloat_t utime,stime;
211  register pointer r=NIL;
212  numunion nu;
213 
214  ckarg(1); who=ckintval(argv[0]);
215  getrusage(who,(struct rusage *)rusage);
216  utime=rusage[0]+rusage[1]*1.0e-6;
217  stime=rusage[2]+rusage[3]*1.0e-6;
218  for (i=17; i>=4; i--) r=cons(ctx,makeint(rusage[i]),r);
219  r=cons(ctx,makeflt(stime),r); r=cons(ctx,makeflt(utime),r);
220  /*(utime stime maxrss ixrss idrss isrss page-reclaims page-faults swap
221  inblock outblock msgsnd msgrcv nsignals
222  voluntary-context-switch involuntary-context-switch) */
223  return(r);}
224 
226 register context *ctx;
227 int n; pointer argv[];
228 { ckarg(0);
229  return(makeint(getpagesize())); }
230 
231 #endif
232 
234 register context *ctx;
235 int n;
236 register pointer argv[];
237 { struct timeval /*{long tv_sec, tv_usec;}*/ tm;
238  eusfloat_t ftime;
239  pointer p;
240 
241  /* (sec usec timezone daylight) */
242  /* timezone is seconds west to the GMT */
243  gettimeofday(&tm, 0);
244  p=cons(ctx, makeint(daylight), NIL);
245  p=cons(ctx, makeint(timezone),p);
246  p=cons(ctx, makeint(tm.tv_usec), p);
247  vpush(p);
248  p=cons(ctx, mkbigint(tm.tv_sec), p);
249  vpop();
250  return(p);}
251 
252 pointer GETITIMER(ctx,n,argv)
253 register context *ctx;
254 int n;
255 register pointer argv[];
256 { int stat;
257  struct itimerval tmval;
258  eusfloat_t interval,value;
259  numunion nu;
260  ckarg(1);
261  stat=getitimer(ckintval(argv[0]), &tmval);
262  if (stat<0) return(NIL);
263  interval=tmval.it_interval.tv_sec + ( tmval.it_interval.tv_usec*1.0E-6);
264  value=tmval.it_value.tv_sec + (tmval.it_value.tv_usec*1.0E-6);
265  return(cons(ctx,makeflt(value),
266  cons(ctx,makeflt(interval),NIL)));}
267 
268 pointer SETITIMER(ctx,n,argv)
269 register context *ctx;
270 int n;
271 register pointer argv[];
272 { int stat;
273  pointer result=NIL;
274  struct itimerval tmval,oldtmval;
275  eusfloat_t interval,value;
276  numunion nu;
277 
278  ckarg(3);
279  value=ckfltval(argv[1]); interval=ckfltval(argv[2]);
280  tmval.it_value.tv_sec=value;
281  tmval.it_value.tv_usec=(value-tmval.it_value.tv_sec)*1.0E6;
282  tmval.it_interval.tv_sec=interval;
283  tmval.it_interval.tv_usec=(interval-tmval.it_interval.tv_sec)*1.0E6;
284  stat=setitimer(ckintval(argv[0]), &tmval, &oldtmval);
285  if (stat<0) return(result);
286  interval=oldtmval.it_interval.tv_sec + (oldtmval.it_interval.tv_usec*1.0E-6);
287  value=oldtmval.it_value.tv_sec + (oldtmval.it_value.tv_usec*1.0E-6);
288  return(cons(ctx,makeflt(interval),
289  cons(ctx,makeflt(value),result)));}
290 #endif /* ! vxworks */
291 
292 /****************************************************************/
293 /* signal handling
294 /****************************************************************/
295 
296 #ifdef SIGADDSET
297 #undef SIGADDSET
298 #endif
299 #ifdef SIGDELSET
300 #undef SIGDELSET
301 #endif
302 
303 pointer SIGADDSET(ctx,n,argv)
304 register context *ctx;
305 int n;
306 register pointer argv[];
307 { int signum;
308  sigset_t *set;
309  ckarg(2);
310  signum=ckintval(argv[1]);
311  if (isvector(argv[0]) &&
312  ((elmtypeof(argv[0])==ELM_INT) || (elmtypeof(argv[0])==ELM_BIT))) {
313  set=(sigset_t *)argv[0]->c.ivec.iv;
314  sigaddset(set, signum);
315  return(argv[0]);}
316  else error(E_USER,(pointer)"integer/bit vector expected for sigaddset");
317  }
318 
319 pointer SIGDELSET(ctx,n,argv)
320 register context *ctx;
321 int n;
322 register pointer argv[];
323 { int signum;
324  sigset_t *set;
325  ckarg(2);
326  signum=ckintval(argv[1]);
327  if (isvector(argv[0]) &&
328  ((elmtypeof(argv[0])==ELM_INT) || (elmtypeof(argv[0])==ELM_BIT))) {
329  set=(sigset_t *)argv[0]->c.ivec.iv;
330  sigdelset(set, signum);
331  return(argv[0]);}
332  else error(E_USER,(pointer)"integer/bit vector expected for sigaddset");
333  }
334 
336 context *ctx;
337 int n;
338 pointer argv[];
339 { sigset_t *set, *oset;
340  int how, stat;
341  ckarg2(2,3);
342  how=ckintval(argv[0]);
343  if (isvector(argv[1]) &&
344  ((elmtypeof(argv[1])==ELM_INT) || (elmtypeof(argv[1])==ELM_BIT))) {
345  set=(sigset_t *)argv[1]->c.ivec.iv;
346  if (isvector(argv[2]) &&
347  ((elmtypeof(argv[2])==ELM_INT) || (elmtypeof(argv[2])==ELM_BIT)))
348  oset=(sigset_t *)argv[2]->c.ivec.iv;
349  else oset=(sigset_t *)0;
350  stat=sigprocmask(how, set, oset);
351  if (stat==0) return(T); else return(makeint(-errno));
352  }
353  else error(E_USER,(pointer)"integer/bit vector expected for sigprocmask");
354  }
355 
356 pointer KILL(ctx,n,argv)
357 register context *ctx;
358 int n;
359 register pointer argv[];
360 { ckarg(2);
361  return(makeint(kill(ckintval(argv[0]),ckintval(argv[1]))));}
362 
363 #if Solaris2 || Linux || IRIX || IRIX6 || Cygwin
364 pointer SIGNAL(ctx,n,argv)
365 register context *ctx;
366 int n;
367 pointer argv[];
368 { register int s,i;eusinteger_t f;
369  struct sigaction sv;
370  register pointer a=argv[1],oldval;
371  extern void eusint();
372 
373  ckarg2(1,3);
374  s=min(ckintval(argv[0]),NSIG-1);
375  oldval=eussigvec[s];
376  if (n==1) return(oldval);
377  if (isint(a)) { f=max(1,intval(a)); eussigvec[s]=NIL;}
378  else { f=(eusinteger_t)eusint; eussigvec[s]=a;}
379  sv.sa_handler= (void (*)())f;
380 #if Linux || Cygwin
381 
382 #if LIB6 && !Darwin
383  for (i=0; i< _SIGSET_NWORDS; i++) sv.sa_mask.__val[i]=0;
384 #else
385  /* old type sigmask */
386  sv.sa_mask=0;
387 #endif
388 /*LIB6*/
389 
390 #elif (IRIX || IRIX6) && !IRIX6_2
391  for (i=0; i<4; i++) sv.sa_mask.sigbits[i]=0;
392 #else
393  for (i=0; i<4; i++) sv.sa_mask.__sigbits[i]=0;
394 #endif
395 
396  if (n==3) sv.sa_flags= ckintval(argv[2]);
397  else sv.sa_flags=0;
398  /* printf("signal %d flag=%d\n", s, sv.sa_flags); */
399  s=sigaction(s,&sv,0);
400  if (s== -1) return(makeint(-errno)); else return(oldval);
401  }
402 
403 #else
404 pointer SIGNAL(ctx,n,argv)
405 register context *ctx;
406 int n;
407 pointer argv[];
408 { register int s;eusinteger_t f;
409  struct sigvec sv;
410  register pointer a=argv[1],oldval;
411  extern void eusint();
412 
413  ckarg2(1,3);
414  s=min(ckintval(argv[0]),NSIG-1);
415  oldval=eussigvec[s];
416  if (n==1) return(oldval);
417  if (isint(a)) { f=max(1,intval(a)); eussigvec[s]=NIL;}
418  else { f=(eusinteger_t)eusint; eussigvec[s]=a;}/* ???? */
419  sv.sv_handler=(void (*)())f;
420  sv.sv_mask=0; /*sigmask(s)???;*/
421 /*news doesn't have system5 compatible signal handling option*/
422 #if sun3 || sun4 || mips || alpha
423  if (n==3) sv.sv_flags=ckintval(argv[2]);
424  else sv.sv_flags=0;
425 #endif
426  s=sigvec(s,&sv,0);
427  if (s== -1) return(makeint(-errno)); else return(oldval);
428  }
429 
430 #endif
431 
432 #if !vxworks
433 
434 #include <sys/wait.h>
435 pointer WAIT(ctx,n,argv)
436 register context *ctx;
437 int n;
438 pointer argv[];
439 { int completion=0, stat;
440  GC_REGION(stat = wait(&completion););
441  return(cons(ctx,makeint(stat),
442  cons(ctx,makeint(completion),NIL)));}
443 
444 pointer ALARM(ctx,n,argv)
445 register context *ctx;
446 int n; pointer argv[];
447 { ckarg(1);
448  return(makeint(alarm(ckintval(argv[0]))));}
449 
450 
451 #if sun3 || sun4 || news || sanyo || alpha || i386 || x86_64 || ARM
452 #if !Solaris2
453 pointer UALARM(ctx,n,argv)
454 register context *ctx;
455 int n; pointer argv[];
456 { ckarg(2);
457  return(makeint(ualarm(ckintval(argv[0]), ckintval(argv[1]))));}
458 #endif
459 #endif
460 
461 #endif
462 
463 /**********************************************/
464 /* process, user, and group identification
465 /**********************************************/
466 
467 pointer GETPID(ctx,n,argv)
468 register context *ctx;
469 int n;
470 pointer *argv; /* unused argument */
471 { ckarg(0);
472  return(makeint(getpid()));}
473 
474 #if !vxworks
475 pointer GETPPID(ctx,n,argv)
476 register context *ctx;
477 int n;
478 pointer argv[];
479 { ckarg(0);
480  return(makeint(getppid()));}
481 
482 pointer GETPGRP(ctx,n,argv)
483 register context *ctx;
484 int n;
485 pointer argv[];
486 #if system5 | Linux | Cygwin
487 { ckarg(0);
488  return(makeint(getpgrp()));}
489 #else
490 { int pid;
491  if (n==1) pid=ckintval(argv[0]);
492  else pid=getpid();
493  return(makeint(getpgrp(pid)));}
494 #endif
495 
496 pointer SETPGRP(context *ctx, int n, pointer *argv)
497 #if system5 | Linux | Cygwin
498 { ckarg(0);
499  return(makeint(setpgrp()));}
500 #else
501 { int pid;
502  ckarg(2);
503  return(makeint(setpgrp(ckintval(argv[0]),ckintval(argv[1]))));}
504 #endif
505 
506 pointer GETUID(context *ctx, int n, pointer *argv)
507 { ckarg(0);
508  return(makeint(getuid()));}
509 
510 pointer GETEUID(ctx,n,argv)
511 register context *ctx;
512 int n;
513 pointer argv[];
514 { ckarg(0);
515  return(makeint(geteuid()));}
516 
517 pointer GETGID(ctx,n,argv)
518 register context *ctx;
519 int n;
520 pointer argv[];
521 { ckarg(0);
522  return(makeint(getgid()));}
523 
524 pointer GETEGID(ctx,n,argv)
525 register context *ctx;
526 int n;
527 pointer argv[];
528 { ckarg(0);
529  return(makeint(getegid()));}
530 
531 pointer SETUID(ctx,n,argv)
532 register context *ctx;
533 int n;
534 pointer argv[];
535 { ckarg(1);
536  n=setuid(ckintval(argv[0]));
537  if (n<0) return(makeint(errno)); else return(T);}
538 
539 pointer SETGID(ctx,n,argv)
540 register context *ctx;
541 int n;
542 pointer argv[];
543 { ckarg(1);
544  n=setgid(ckintval(argv[0]));
545  if (n<0) return(makeint(errno)); else return(T);}
546 
547 #endif
549 #if system5 || Linux || Cygwin
550 pointer UNAME(ctx,n,argv)
551 register context *ctx;
552 int n;
553 pointer *argv;
554 { struct utsname u;
555  pointer s;
556  ckarg(0);
557  uname(&u);
558  vpush(makestring(u.sysname,strlen(u.sysname)));
559  vpush(makestring(u.nodename,strlen(u.nodename)));
560  vpush(makestring(u.release,strlen(u.release)));
561  vpush(makestring(u.version,strlen(u.version)));
562  vpush(makestring(u.machine,strlen(u.machine)));
563  s=stacknlist(ctx,5);
564  return(s);}
565 #endif
566 
567 /****************************************************************/
568 /* process creation and deletion
569 /****************************************************************/
570 #if !vxworks
571 #if !Solaris2 || !THREADED
572 pointer FORK(ctx,n,argv)
573 register context *ctx;
574 int n;
575 pointer *argv;
576 { ckarg(0);
577  return(makeint(fork()));
578  }
579 #else
580 /* for the problem of calling fork(2) in MT *
581  * Jan. 10 2003 by ikuo@jsk.t.u-tokyo.ac.jp */
582 static int ctxid_in_child;
583 static void *prepare(void) {
584  int i, me=thr_self();
585  /* preserve current context */
586  ctxid_in_child=me;
587  /* suspend all threads except self */
588  for (i=0; i<MAXTHREAD; i++) {
589  if (euscontexts[i]!=0 && i!=me &&
590  euscontexts[i]->threadobj->c.thrp.suspend==NIL) {
591  thr_suspend(i);
592  euscontexts[i]->threadobj->c.thrp.suspend=T; } }
593 }
594 static void *parent(void) {
595  /* continue all suspended threads */
596  int i, me=thr_self();
597  for (i=0; i<MAXTHREAD; i++) {
598  if (euscontexts[i]!=0 && i!=me) {
599  euscontexts[i]->threadobj->c.thrp.suspend=NIL;
600  thr_continue(i); } }
601 }
602 static void *child(void) {
603  /* do not continue suspended threads */
604  int me=thr_self();
605  /* copy current context (tid changed in child) */
607 }
608 pointer FORK(register context *ctx, int n, pointer *argv)
609 {ckarg(0);
610  pthread_atfork (prepare, parent, child);
611  return(makeint(fork()));
612 }
613 #endif /* endof Solaris || THREADED */
614 
615 #if Solaris2
616 pointer FORK1(ctx,n,argv)
617 register context *ctx;
618 int n;
619 pointer *argv;
620 { ckarg(0);
621  return(makeint(fork1()));
622  }
623 #endif
624 
625 #if sun3 || sun4 || vax || news || sanyo || (mips && !IRIX && !IRIX6) || i386 || alpha || x86_64 || ARM
626 pointer VFORK(ctx,n,argv)
627 register context *ctx;
628 int n;
629 pointer *argv;
630 { ckarg(0);
631  return(makeint(vfork()));}
632 #endif
633 
634 pointer EXEC(ctx,n,argv)
635 register context *ctx;
636 int n;
637 pointer *argv;
638 { byte *exeargv[512];
639  int i=0,stat;
640  if (n>512) error(E_MISMATCHARG);
641  while (i<n) {
642  exeargv[i]=Getstring(argv[i])->c.str.chars;
643  i++;}
644  exeargv[i]=0;
645  stat=execvp(exeargv[0],(char **)exeargv);
646  return(makeint(-errno));}
647 
648 #if !Solaris2
649 static pointer SETPRIORITY(ctx,n,argv)
650 register context *ctx;
651 int n;
652 pointer *argv;
653 /* (SETPRIORITY which who priority)
654  which 0:process, 1:process-group, 2:user
655  who 0:self, others pid, pgrp-id user-id */
656 { ckarg(3);
657  return(makeint(setpriority(ckintval(argv[0]),
658  ckintval(argv[1]),
659  ckintval(argv[2]))));}
660 
661 static pointer GETPRIORITY(ctx,n,argv)
662 register context *ctx;
663 int n;
664 pointer *argv;
665 /* (GETPRIORITY which who) */
666 { ckarg(2);
667  return(makeint(getpriority(ckintval(argv[0]), ckintval(argv[1]))));}
668 #endif
669 #endif
671 pointer EXIT(ctx,n,argv)
672 register context *ctx;
673 int n;
674 pointer *argv;
675 { pointer exithook=speval(QEXITHOOK);
676 /*
677  Exit function can not finish threads which create in Euslisp
678 on SunOS 4.1. So we use thr_exit function on SunOS 4.1.
679 */
680 #if SunOS4_1 /* changed by H.Nakagaki at 28-Jun-1995 */
681  if (n==0) thr_exit(0);
682  else thr_exit(ckintval(argv[0]));
683 #else
684  if (exithook != NIL) {
685  ufuncall(ctx,exithook,exithook,(pointer)(ctx->vsp-n),0,n);}
686  if (n==0) exit(0);
687  else exit(ckintval(argv[0]));
688 #endif
689 }
690 
691 pointer _EXIT(ctx,n,argv)
692 register context *ctx;
693 int n;
694 pointer *argv;
695 { pointer exithook=speval(QEXITHOOK);
696  if (n==0) _exit(0);
697  else _exit(ckintval(argv[0]));
698 }
699 
700 /****************************************************************/
701 /* unix raw I/O and file systems
702 /****************************************************************/
703 
704 pointer UNIXREAD(ctx,n,argv)
705 register context *ctx;
706 int n;
707 pointer argv[];
708 /* (unix:read stream [length]) */
709 /* (unix:read fd buffer [length [offset]]) */
710 #if (WORD_SIZE == 64)
711 { register int fd,offset=0;
712  register long int size;
713 #else
714 { register int fd,size,offset=0;
715 #endif
716  register pointer strm,buf,count;
717  byte *bufp;
718 
719  ckarg2(1,4);
720  strm=argv[0];
721  if (isiostream(strm)) strm=strm->c.iostream.in;
722  if (isfilestream(strm)) {
723  if (strm->c.stream.direction!=K_IN) error(E_IODIRECTION);
724  if (isint(strm->c.fstream.fname)) error(E_STREAM);
725  buf=strm->c.fstream.buffer;
726  bufp=buf->c.str.chars;
727  fd=intval(strm->c.fstream.fd);
728  if (n==2) size=min(strlength(buf),ckintval(argv[1]));
729  else size=strlength(buf);}
730  else if (isint(strm)) {
731  fd=intval(strm);
732  buf=argv[1];
733  if (isvector(buf) && (elmtypeof(buf)==ELM_FOREIGN))
734  bufp=buf->c.foreign.chars;
735  else if (isstring(buf)) bufp=buf->c.str.chars;
736  else error(E_NOSTRING);
737  if (n>=3) size=min(strlength(buf),ckintval(argv[2]));
738  else size=strlength(buf);
739  if (n==4) offset=ckintval(argv[3]);}
740  else error(E_STREAM);
741  GC_REGION(size=read(fd, &bufp[offset],size););
742  count=makeint(size);
743  if (isstream(strm)) {
744  strm->c.stream.count=0; strm->c.stream.tail=count;}
745  if (size<0) return(makeint(-errno));
746  else return(count);}
747 
748 pointer UNIXWRITE(ctx,n,argv)
749 register context *ctx;
750 register int n;
751 pointer *argv;
752 /* (unix:write fd string [count])
753  (unix:write stream string [count]) */
754 { register pointer strm,buf;
755  register int size,fd;
756  byte *bufp;
757  ckarg2(2,3);
758  strm=argv[0];
759  if (isiostream(strm)) strm=strm->c.iostream.out;
760  if (isfilestream(strm)) {
761  if (strm->c.stream.direction!=K_OUT) error(E_IODIRECTION);
762  if (isint(strm->c.fstream.fname)) error(E_STREAM);
763  fd=intval(strm->c.fstream.fd);}
764  else if (isint(strm)) fd=intval(strm);
765  else error(E_STREAM);
766  buf=argv[1];
767  if (isvector(buf) && (elmtypeof(buf)==ELM_FOREIGN))
768  bufp=buf->c.foreign.chars;
769  else if (isstring(buf)) bufp=buf->c.str.chars;
770  else error(E_NOSTRING);
771  size=strlength(buf);
772  if (n==3) size=min(size,ckintval(argv[2]));
773  size=write(fd,bufp,size);
774  return(makeint(size));}
775 
776 
777 pointer UNIXCLOSE(ctx,n,argv)
778 register context *ctx;
779 int n;
780 pointer argv[];
781 { ckarg(1);
782  if (close(ckintval(argv[0]))==0) return(T); else return(makeint(errno));}
783 
784 
785 #if !Cygwin /* Cygwin does not have lockf */
786 pointer LOCKF(ctx,n,argv)
787 register context *ctx;
788 int n;
789 pointer argv[];
790 { register pointer a=argv[0];
791  int fd,func,size,result;
792  ckarg2(2,3);
793  if (isiostream(a)) a=a->c.iostream.out;
794  if (isfilestream(a)) fd=intval(a->c.fstream.fd);
795  else if (isint(argv[0])) fd=intval(argv[0]);
796  else error(E_STREAM);
797  func= ckintval(argv[1]);
798  if (n==3) size=ckintval(argv[2]);
799  else size=0;
800  result=lockf(fd,func,size);
801  return(makeint(result));}
802 #endif
803 
804 #include <fcntl.h>
805 pointer FCNTL(ctx,n,argv)
806 register context *ctx;
807 int n;
808 pointer argv[];
809 { register pointer a=argv[0]; int fd,result;
810  ckarg(3);
811  if (isiostream(a)) a=a->c.iostream.in;
812  if (isfilestream(a)) fd=intval(a->c.fstream.fd);
813  else if (isint(argv[0])) fd=intval(argv[0]);
814  else error(E_STREAM);
815  result=fcntl(fd,ckintval(argv[1]),ckintval(argv[2]));
816  return(makeint(result));}
817 
818 
819 pointer IOCTL(ctx,n,argv)
820 register context *ctx;
821 int n;
822 register pointer argv[];
823 { register pointer strm;
824  eusinteger_t ctlarg;
825  int request;
826  int fd;
827  ckarg(3);
828  strm=argv[0];
829  if (isiostream(strm)) strm=strm->c.iostream.out;
830  if (isfilestream(strm)) {
831  fd=intval(strm->c.fstream.fd);
832  if (isint(strm->c.fstream.fname)) error(E_STREAM);}
833  else fd=ckintval(argv[0]);
834  if (isint(argv[1])) request=ckintval(argv[1]);
835  else if (isflt(argv[1])) error(E_NOINT);
836  else request=argv[1]->c.ivec.iv[0];
837  if (isstring(argv[2])) ctlarg=(eusinteger_t)(argv[2]->c.str.chars);/* ???? */
838  else ctlarg=ckintval(argv[2]);
839  return(makeint(ioctl(fd,request,ctlarg)));
840  }
841 
842 
843 #if !vxworks && !Solaris2
844 int bytesize(p)
845 pointer p;
846 { register int s=vecsize(p);
847  switch (elmtypeof(p)) {
848  case ELM_BIT: return((s+7)/8);
849  case ELM_BYTE: case ELM_CHAR: case ELM_FOREIGN: return(s);
850  case ELM_FLOAT: return(s*sizeof(float));
851  case ELM_INT: return(s*sizeof(int));
852  default: return(s*sizeof(pointer));}}
853 
854 #if Linux_ppc
855 #define IOC_IN _IOC_READ
856 #define IOC_OUT _IOC_WRITE
857 #define IOC_INOUT (IOC_IN | IOC_OUT)
858 #endif
859 
860 
861 pointer IOCTL_(ctx,n,argv)
862 register context *ctx;
863 /* (UNIX:IOCTL_ stream command1 command2) */
864 /* equivalent to C's ioctl(dev, _IO(command1, command2), addr) */
865 int n;
866 register pointer argv[];
867 { register pointer strm;
868  int size=0,x,y,fd;
869  eusinteger_t addr;
870  ckarg(3);
871  strm=argv[0];
872  if (isiostream(strm)) strm=strm->c.iostream.out;
873  if (isfilestream(strm)) fd=intval(strm->c.fstream.fd);
874  else fd=ckintval(strm);
875  if (isint(strm->c.fstream.fname)) error(E_STREAM);
876  x=ckintval(argv[1]); y=ckintval(argv[2]);
877 #if alpha || Linux_ppc
878  if (ioctl(fd,_IO(x, y), addr))
879 #else
880  if (ioctl(fd,IOC_VOID | (size<<16) | (x<<8) | y, addr))
881 #endif
882  return(makeint(-errno));
883  else return(T); }
884 
885 pointer IOCTL_R(ctx,n,argv)
886 register context *ctx;
887 /* (UNIX:IOCTL_R stream x y buffer [size]) */
888 /* equivalent to C's ioctl(dev, _IORN(size, x, y), addr) */
889 int n;
890 register pointer argv[];
891 { register pointer strm;
892  int size,x,y,fd;
893  eusinteger_t addr;
894  ckarg2(4,5);
895  strm=argv[0];
896  if (isiostream(strm)) strm=strm->c.iostream.out;
897  if (isfilestream(strm)) fd=intval(strm->c.fstream.fd);
898  else fd=ckintval(strm);
899  if (isint(strm->c.fstream.fname)) error(E_STREAM);
900  x=ckintval(argv[1]); y=ckintval(argv[2]);
901  if (isstring(argv[3]) || isintvector(argv[3]))
902  addr=(eusinteger_t)(argv[3]->c.str.chars);/* ???? */
903  else error(E_NOSTRING);
904  if (n==5) size=ckintval(argv[4]);
905  else size=bytesize(argv[3]);
906 #if alpha
907  if (ioctl(fd,_IOC(IOC_OUT, x, y, size), addr))
908 #else
909  if (ioctl(fd,IOC_OUT | (size<<16) | (x<<8) | y, addr))
910 #endif
911  return(makeint(-errno));
912  else return(T); }
913 
914 pointer IOCTL_W(ctx,n,argv)
915 register context *ctx;
916 /* (UNIX:IOCTL_W stream x y buffer [size]) */
917 /* equivalent to C's ioctl(dev, _IOWN(size, x, y), addr) */
918 int n;
919 register pointer argv[];
920 { register pointer strm;
921  int size,x,y,fd;
922  eusinteger_t addr;
923  ckarg2(4,5);
924  strm=argv[0];
925  if (isiostream(strm)) strm=strm->c.iostream.out;
926  if (isfilestream(strm)) fd=intval(strm->c.fstream.fd);
927  else fd=ckintval(strm);
928  if (isint(strm->c.fstream.fname)) error(E_STREAM);
929  x=ckintval(argv[1]); y=ckintval(argv[2]);
930  if (isstring(argv[3]) || isintvector(argv[3]))
931  addr=(eusinteger_t)(argv[3]->c.str.chars);/* ???? */
932  else error(E_NOSTRING);
933  if (n==5) size=ckintval(argv[4]);
934  else size=bytesize(argv[3]);
935 #if alpha || Linux_ppc
936  if (ioctl(fd,_IOC(IOC_IN, x, y, size), addr))
937 #else
938  if (ioctl(fd,IOC_IN | (size<<16) | (x<<8) | y, addr))
939 #endif
940  return(makeint(-errno));
941  else return(T); }
942 
943 #if !Cygwin /* Cygwin does not have IOC_INOUT */
944 pointer IOCTL_WR(ctx,n,argv)
945 register context *ctx;
946 /* (UNIX:IOCTL_WR stream x y buffer [size]) */
947 /* equivalent to C's ioctl(dev, _IOWRN(size, x, y), addr) */
948 int n;
949 register pointer argv[];
950 { register pointer strm=argv[0];
951  int size,x,y,fd;
952  eusinteger_t addr;
953 
954  ckarg2(4,5);
955  if (isiostream(strm)) strm=strm->c.iostream.out;
956  if (isfilestream(strm)) fd=intval(strm->c.fstream.fd);
957  else fd=ckintval(strm);
958  if (isint(strm->c.fstream.fname)) error(E_STREAM);
959  x=ckintval(argv[1]); y=ckintval(argv[2]);
960  if (isstring(argv[3]) || isintvector(argv[3]))
961  addr=(eusinteger_t)(argv[3]->c.str.chars);
962  else error(E_NOSTRING);
963  if (n==5) size=ckintval(argv[4]);
964  else size=bytesize(argv[3]);
965 #if alpha || Linux_ppc
966  if (ioctl(fd,_IOC(IOC_INOUT, x, y, size), addr))
967 #else
968  if (ioctl(fd,IOC_INOUT | (size <<16) | (x<<8) | y, addr))
969 #endif
970  return(makeint(-errno)) ;
971  else return(T); }
972 #endif /*Cygwin*/
973 
974 #endif /*vxworks*/
975 
976 /* DUP and DUP2 work only for numeric fd, not for stream obj.*/
977 #if !vxworks
978 
979 pointer DUP(ctx,n,argv)
980 register context *ctx;
981 int n;
982 pointer *argv;
983 { int newfd,oldfd;
984  ckarg(1);
985  oldfd=ckintval(argv[0]);
986  newfd=dup(oldfd);
987  return(makeint(newfd));}
988 
989 pointer DUP2(ctx,n,argv)
990 register context *ctx;
991 int n;
992 pointer *argv;
993 { int newfd,oldfd,stat;
994  ckarg(2);
995  newfd=ckintval(argv[0]);
996  oldfd=ckintval(argv[1]);
997  stat=dup2(newfd,oldfd);
998  return(makeint(stat));}
999 
1000 pointer MKNOD(ctx,n,argv)
1001 register context *ctx;
1002 int n;
1003 pointer *argv;
1004 { int stat;
1005  ckarg(2);
1006  stat=mknod((char *)Getstring(argv[0])->c.str.chars,ckintval(argv[1]),0);
1007  if (stat<0) return(makeint(-errno));
1008  else return(T);}
1009 
1010 pointer MKDIR(ctx, n, argv)
1011 register context *ctx;
1012 int n;
1013 pointer *argv;
1014 { int stat, mode;
1015  ckarg2(1,2);
1016  if (n==2) mode=ckintval(argv[1]); else mode=0775;
1017  stat=mkdir((char *)Getstring(argv[0])->c.str.chars,mode);
1018  if (stat<0) return(makeint(-errno));
1019  else return(T);}
1020 
1021 pointer LINK(ctx,n,argv)
1022 register context *ctx;
1023 int n;
1024 pointer argv[];
1025 { int stat;
1026  ckarg(2);
1027  stat=link(Getstring(argv[0])->c.str.chars,Getstring(argv[1])->c.str.chars);
1028  if (stat<0) return(makeint(-errno)); else return(T);}
1029 
1030 pointer UNLINK(ctx,n,argv)
1031 register context *ctx;
1032 int n;
1033 pointer argv[];
1034 { pointer s;
1035  int stat;
1036  ckarg(1);
1037  s=Getstring(argv[0]);
1038  stat=unlink(s->c.str.chars);
1039  if (stat<0) return(makeint(-errno));
1040  else return(T);}
1041 
1042 pointer RMDIR(ctx,n,argv)
1043 register context *ctx;
1044 int n;
1045 pointer argv[];
1046 { pointer s;
1047  int stat;
1048  ckarg(1);
1049  s=Getstring(argv[0]);
1050  stat=rmdir(s->c.str.chars);
1051  if (stat<0) return(makeint(-errno));
1052  else return(T);}
1053 
1054 pointer RENAME(ctx,n,argv) /*(rename from to)*/
1055 register context *ctx;
1056 int n;
1057 register pointer argv[];
1058 { byte *from, *to;
1059  int stat;
1060  ckarg(2);
1061  from =(byte *)get_string(argv[0]);
1062  to =(byte *)get_string(argv[1]);
1063  stat=rename((char *)from,(char *) to);
1064  if (stat<0) return(makeint(-errno));
1065  else return(T);}
1066 
1067 pointer ACCESS(ctx,n,argv)
1068 register context *ctx;
1069 int n;
1070 pointer *argv;
1071 { pointer path;
1072  int mode,stat;
1073  ckarg2(1,2);
1074  path=Getstring(argv[0]);
1075  if (n==2) mode=ckintval(argv[1]); else mode=0;
1076  stat=access(path->c.str.chars,mode);
1077  if (stat==0) return(T); else return(makeint(-errno));}
1078 
1079 /*
1080 pointer FLOCK(ctx,n,argv)
1081 register context *ctx;
1082 int n;
1083 pointer argv[];
1084 { int fd=ckintval(argv[0]), op=ckintval(argv[1]), stat;
1085  ckarg(2);
1086  stat=flock(fd,op);
1087  if (stat==0) return(T); else return(makeint(-errno));}
1088 */
1089 
1090 pointer STAT(ctx,n,argv)
1091 register context *ctx;
1092 int n;
1093 pointer *argv;
1094 { register pointer a;
1095  struct stat s;
1096  ckarg(1);
1097  if (stat((char *)Getstring(argv[0])->c.str.chars, &s)<0) return(makeint(-errno));
1098  a=cons(ctx,mkbigint(s.st_ctime),NIL);
1099  a=cons(ctx,mkbigint(s.st_mtime),a);
1100  a=cons(ctx,mkbigint(s.st_atime),a);
1101  a=cons(ctx,makeint(s.st_size),a);
1102  a=cons(ctx,makeint(s.st_gid),a);
1103  a=cons(ctx,makeint(s.st_uid),a);
1104  a=cons(ctx,makeint(s.st_nlink),a);
1105  a=cons(ctx,makeint(s.st_rdev),a);
1106  a=cons(ctx,makeint(s.st_dev),a);
1107  a=cons(ctx,makeint(s.st_ino),a);
1108  a=cons(ctx,makeint(s.st_mode),a);
1109  return(a);}
1110 #endif /* !vxworks*/
1111 
1112 #if Solaris2 || Linux || alpha || Cygwin
1113 /*
1114  Usage: (unix::directory "directory_name")
1115  Return: a reverse list of file names in "directory_name" dir.
1116 */
1117 
1118 pointer DIRECTORY(ctx, n, argv)
1119 register context *ctx;
1120 int n;
1121 pointer argv[];
1122 { register pointer a;
1123  register char *str;
1124  byte *s;
1125  DIR *dirp;
1126  struct dirent *direntp;
1127  int flag=0;
1128 
1129  ckarg2(0,1);
1130  if (n==1) s=get_string(argv[0]); else s=(byte *)".";
1131  if ( (dirp = opendir((char *)s)) == NULL ) return (NIL);
1132  while ( (direntp = readdir( dirp )) != NULL ){
1133  str=direntp->d_name;
1134  if(flag) a=cons(ctx,makestring(str,strlen(str)),a);
1135  else { a=cons(ctx,makestring(str,strlen(str)),NIL); flag++;}
1136  }
1137  closedir(dirp);
1138  return (a);
1139 }
1140 #else
1141 pointer DIRECTORY(ctx, n, argv)
1142 register context *ctx;
1143 int n;
1144 pointer argv[];
1145 {
1146  printf("Not Implemented!");
1147  return (NIL);
1148 }
1149 #endif
1150 
1151 pointer LSEEK(ctx,n,argv)
1152 register context *ctx;
1153 int n;
1154 pointer *argv;
1155 { pointer strm,fd;
1156  int whence, ret;
1157  ckarg2(2,3);
1158  if (n==3) whence=ckintval(argv[2]); else whence=0;
1159  strm=argv[0];
1160  if (isiostream(strm)) strm=strm->c.iostream.out;
1161  if (isfilestream(strm)){
1162  fd=strm->c.fstream.fd;
1163  if (isint(strm->c.fstream.fname)) error(E_STREAM);}
1164  else fd=strm;
1165  if (!isint(fd)) error(E_STREAM);
1166  ret=lseek(intval(fd),ckintval(argv[1]),whence);
1167  if (ret==-1) perror("lseek");
1168  return(makeint(ret)); }
1169 
1170 #if !vxworks
1171 /*change current working directory*/
1172 pointer CHDIR(ctx,n,argv)
1173 register context *ctx;
1174 int n;
1175 pointer argv[];
1176 { register int stat;
1177  ckarg(1);
1178  stat=chdir(Getstring(argv[0])->c.str.chars);
1179  if (stat<0) return(makeint(-errno)); else return(T);}
1180 
1181 /*change file access mode*/
1182 pointer CHMOD(ctx,n,argv)
1183 register context *ctx;
1184 int n;
1185 pointer *argv;
1186 { byte *path;
1187  int mode,stat;
1188  ckarg(2);
1189  path=Getstring(argv[0])->c.str.chars;
1190  mode=ckintval(argv[1]);
1191  stat=chmod((char *)path,mode);
1192  if (stat==0) return(T); else return(makeint(errno));}
1193 
1194 /*change file owner*/
1195 pointer CHOWN(ctx,n,argv)
1196 register context *ctx;
1197 int n;
1198 pointer *argv;
1199 { byte *path;
1200  int owner,newowner,stat;
1201  ckarg(3);
1202  path=Getstring(argv[0])->c.str.chars;
1203  owner=ckintval(argv[1]);
1204  newowner=ckintval(argv[2]);
1205  stat=chown(path,owner,newowner);
1206  if (stat==0) return(T); else return(makeint(errno));}
1207 
1208 /*create two pipes*/
1209 pointer PIPE(ctx,n,argv)
1210 register context *ctx;
1211 int n;
1212 pointer *argv;
1213 { int pfd[2],stat,size;
1214  register pointer instream,outstream;
1215 
1216  ckarg2(0,1);
1217  if (n==1) size=ckintval(argv[0]); else size=128;
1218  stat=pipe(pfd);
1219  if (stat<0) return(makeint(-errno));
1220  instream=mkfilestream(ctx,K_IN,makebuffer(size),pfd[0],NIL); /*no file named*/
1221  vpush(instream);
1222  outstream=mkfilestream(ctx,K_OUT,makebuffer(size),pfd[1],NIL);
1223  return((pointer)mkiostream(ctx,vpop(),outstream));
1224  }
1225 
1226 
1227 /* message queu operations */
1228 #if !news
1229 pointer MSGGET(ctx,n,argv)
1230 register context *ctx;
1231 int n;
1232 pointer argv[];
1233 { register int key,qid,mode;
1234  ckarg2(1,2);
1235  key=ckintval(argv[0]);
1236  if (n==2) mode=ckintval(argv[1]); else mode=0666;
1237  qid=msgget(key,IPC_CREAT | (mode & 0777));
1238  return(makeint(qid));}
1239 
1240 pointer MSGRCV(ctx,n,argv)
1241 register context *ctx;
1242 int n;
1243 pointer *argv;
1244 { register int qid,mtype,flag,stat;
1245  register pointer buf,lsave;
1246  ckarg2(2,4);
1247  qid=ckintval(argv[0]);
1248  buf=argv[1];
1249  if (!isstring(buf)) error(E_NOSTRING);
1250  if (n>=3) mtype=ckintval(argv[2]); else mtype=0;
1251  if (n==4) if (argv[3]==NIL) flag=0; else flag=IPC_NOWAIT;
1252  else flag=0;
1253  lsave=buf->c.str.length;
1254  buf->c.str.length=(pointer)(eusinteger_t)mtype;/* ???? */
1255  rcv_again:
1256  stat=msgrcv(qid,&buf->c.str.length,intval(lsave),mtype,flag);
1257  if (stat<0) { breakck; goto rcv_again;}
1258  mtype=(int)(eusinteger_t)(buf->c.str.length);/* ???? */
1259  buf->c.str.length=lsave;
1260  if (stat<0) return(makeint(-errno));
1261  else return(cons(ctx,makeint(mtype),cons(ctx,makeint(stat),NIL)));}
1262 
1263 pointer MSGSND(ctx,n,argv)
1264 register context *ctx;
1265 int n;
1266 pointer *argv;
1267 { register int qid,msize,mtype,flag,stat;
1268  register pointer buf,lsave;
1269  ckarg2(2,5);
1270  qid=ckintval(argv[0]);
1271  buf=argv[1];
1272  if (!isstring(buf)) error(E_NOSTRING);
1273  lsave=buf->c.str.length;
1274  if (n>=3) {
1275  msize=ckintval(argv[2]);
1276  if (msize>intval(lsave) || msize<0) error(E_ARRAYINDEX);}
1277  else msize=intval(lsave);
1278  if (n>=4) mtype=ckintval(argv[3]); else mtype=mypid;
1279  if (n==5) if (argv[4]==NIL) flag=0; else flag=IPC_NOWAIT;
1280  else flag=0;
1281  buf->c.str.length=(pointer)(eusinteger_t)mtype;
1282  stat=msgsnd(qid,(struct msgbuf *)&buf->c.str.length,msize,flag);
1283  buf->c.str.length=lsave;
1284  if (stat<0) return(makeint(-errno));
1285  else return(makeint(stat));}
1286 
1287 pointer MSGCTL(ctx,n,argv)
1288 register context *ctx;
1289 int n;
1290 pointer argv[];
1291 { int qid,cmnd,stat;
1292  byte *buf;
1293  ckarg2(2,3);
1294  qid=ckintval(argv[0]); cmnd=ckintval(argv[1]);
1295  if (n==3) buf=get_string(argv[2]);
1296  else buf=NULL;
1297  stat=msgctl(qid,cmnd,(struct msqid_ds *)buf);
1298  if (stat==(long int)NULL) return(T); else return(makeint(-errno));}
1299 #endif
1300 #endif
1301 
1302 /****************************************************************/
1303 /* UNIX subroutines
1304 /****************************************************************/
1305 
1306 pointer SYSTEM(ctx,n,argv)
1307 register context *ctx;
1308 int n;
1309 register pointer argv[];
1310 { int stat;
1311  eusinteger_t s;
1312 /* extern int eusint(); */
1313  extern void eusint(); /* ???? */
1314 
1315  s=(eusinteger_t)signal(SIGCHLD,SIG_DFL);/* ???? */
1316  if (n==0) stat=system("csh");
1317  else if (isstring(argv[0])) stat=system((char *)argv[0]->c.str.chars);
1318  else { signal(SIGCHLD,(void (*)())s); error(E_NOSTRING);}
1319  signal(SIGCHLD,(void (*)())s);
1320  return(makeint(stat));}
1321 
1322 pointer GETWD(ctx,n,argv)
1323 register context *ctx;
1324 int n;
1325 pointer argv[];
1326 { char buf[256];
1327  ckarg(0);
1328 #if Solaris2 || Linux || Cygwin
1329  char *r = getcwd(buf,256);
1330 #else
1331  getwd(buf);
1332 #endif
1333  return(makestring(buf,strlen(buf)));}
1334 
1335 pointer GETENV(ctx,n,argv)
1336 register context *ctx;
1337 int n;
1338 pointer *argv;
1339 { register char *envval;
1340  ckarg(1);
1341  envval=(char *)getenv((char *)Getstring(argv[0])->c.str.chars);
1342  if (envval) return(makestring(envval,strlen(envval)));
1343  else return(NIL);}
1344 
1345 #if sun3 || sun4 || vax || mips || i386 || alpha || x86_64 || ARM
1346 pointer PUTENV(ctx,n,argv)
1347 register context *ctx;
1348 int n;
1349 pointer argv[];
1350 {
1351  char *b;
1352  pointer a=argv[0];
1353  ckarg(1);
1354  if (!isstring(a)) error(E_NOSTRING);
1355  b= (char *)malloc(vecsize(a)+1);
1356  strcpy(b, (char *)a->c.str.chars);
1357  putenv(b);
1358  return(makeint((eusinteger_t)b));}
1359 #endif
1360 
1361 pointer ENVIRON(context *ctx, int n, pointer argv[])
1362 { extern char **environ;
1363  char *b;
1364  int count=0;
1365  ckarg(0);
1366  while ((b=environ[count++])) {
1367  vpush(makestring(b, strlen(b)));}
1368  return(stacknlist(ctx, count-1)); }
1369 
1370 pointer SLEEP(ctx,n,argv)
1371 register context *ctx;
1372 int n;
1373 pointer *argv;
1374 { ckarg(1);
1375  struct timespec treq;
1376  GC_REGION(treq.tv_sec=ckintval(argv[0]));;
1377  treq.tv_nsec = 0;
1378  if (nanosleep(&treq, NULL)<0) return(NIL);
1379  return(T);}
1380 
1381 
1382 #if sun3 || sun4 && !Solaris2 || Linux || alpha || Cygwin
1383 pointer USLEEP(ctx,n,argv)
1384 register context *ctx;
1385 int n;
1386 pointer *argv;
1387 { ckarg(1);
1388  struct timespec treq;
1389  GC_REGION(treq.tv_sec = ckintval(argv[0])/1000000;
1390  treq.tv_nsec = (ckintval(argv[0])%1000000)*1000);
1391  if (nanosleep(&treq, NULL)<0) return(NIL);
1392  return(T);}
1393 #endif
1394 
1395 pointer ERRNO(ctx,n,argv)
1396 context *ctx;
1397 int n;
1398 pointer argv[];
1399 {
1400  return(makeint(errno));
1401  }
1402 
1403 pointer PERROR(ctx,n,argv)
1404 context *ctx;
1405 int n;
1406 pointer argv[];
1407 {
1408  ckarg(1);
1409  char *s=Getstring(argv[0])->c.str.chars;
1410  fprintf(stderr, "%c[3%cm;; ERROR ", 0x1b, 49);
1411  perror(s);
1412  fprintf(stderr, "%c[0m", 0x1b);
1413  return T;
1414  }
1415 
1416 pointer SYSERRLIST(ctx,n,argv)
1417 register context *ctx;
1418 register int n;
1419 pointer argv[];
1420 { int i;
1421  char *errstr;
1422  int errno_save;
1423  ckarg(1);
1424  n=ckintval(argv[0]);
1425  errno_save=errno;
1426  errstr=strerror(n);
1427  if (errno==errno_save) return(makestring(errstr, strlen(errstr)));
1428  else error(E_ARRAYINDEX);}
1429 
1430 pointer PAUSE(ctx,n,argv)
1431 register context *ctx;
1432 int n;
1433 pointer argv[];
1434 { ckarg(0);
1435  return(makeint(pause()));}
1436 
1437 pointer ISATTY(ctx,n,argv)
1438 register context *ctx;
1439 int n;
1440 pointer argv[];
1441 { pointer a;
1442  int fd;
1443  ckarg(1);
1444  a=argv[0];
1445  if (isiostream(a)) a=a->c.iostream.in;
1446  if (isfilestream(a)) fd=intval(a->c.fstream.fd);
1447  else fd=ckintval(a);
1448  /*
1449 #if Cygwin
1450  if (getenv("EMACS") && (strcmp (getenv("EMACS"), "t")) == 0 ) return(T);
1451 #endif
1452  */
1453  if (isatty(fd)) return(T); else return(NIL);}
1454 
1455 
1456 /****************************************************************/
1457 /* functions for I P C (interprocess communication)
1458 /* using sockets
1459 /* 1988-Jan socket for internet
1460 /* 1988-Feb select system call
1461 /****************************************************************/
1462 
1463 pointer SOCKET(ctx,n,argv)
1464 register context *ctx;
1465 int n;
1466 pointer argv[];
1467 { int proto,s;
1468  ckarg2(2,3);
1469  if (n==3) proto=ckintval(argv[2]);
1470  else proto=0;
1471  s=socket(ckintval(argv[0]),ckintval(argv[1]),proto);
1472  if (s<0) return(makeint(-errno));
1473  else return(makeint(s)); }
1474 
1475 pointer BIND(ctx,n,argv) /*bind ipc socket to real path name*/
1476 register context *ctx;
1477 int n;
1478 register pointer argv[];
1479 { int s,l;
1480  pointer sockname;
1481  struct sockaddr *sa;
1482 
1483  ckarg(2);
1484  s=ckintval(argv[0]); /*socket id*/
1485  if (!isstring(argv[1])) error(E_USER,(pointer)"socket address expected");
1486  sa= (struct sockaddr *)(argv[1]->c.str.chars);
1487  if (sa->sa_family==AF_UNIX) l=strlen(sa->sa_data)+2;
1488  else l=sizeof(struct sockaddr_in);
1489  s=(int)bind(s, sa, l);
1490  if (s) return(makeint(-errno)); else return(makeint(0));}
1491 
1492 pointer CONNECT(ctx,n,argv)
1493 register context *ctx;
1494 int n;
1495 pointer argv[];
1496 { int s,l;
1497  struct sockaddr *sa;
1498  ckarg(2);
1499  s=ckintval(argv[0]); /*socket id*/
1500  if (!isstring(argv[1])) error(E_USER,(pointer)"socket address expected");
1501  sa= (struct sockaddr *)(argv[1]->c.str.chars);
1502  if (sa->sa_family==AF_UNIX) l=strlen(sa->sa_data)+2;
1503  else l=sizeof(struct sockaddr_in);
1504  s=(int)connect(s, sa, l);
1505  breakck;
1506  if (s) return(makeint(-errno)); else return(makeint(0));
1507 }
1508 
1509 pointer LISTEN(ctx,n,argv)
1510 register context *ctx;
1511 int n;
1512 pointer argv[];
1513 { int backlog,stat;
1514  ckarg2(1,2);
1515  if (n==2) backlog=ckintval(argv[1]);
1516  else backlog=3;
1517  stat=listen(ckintval(argv[0]),backlog);
1518  if (stat<0) return(makeint(-errno)); else return(makeint(0));}
1519 
1520 pointer ACCEPT(ctx,n,argv)
1521 register context *ctx;
1522 int n;
1523 pointer argv[];
1524 { int ns,len,s;
1525  pointer sockname;
1526 #if vxworks || Cygwin || Linux || Solaris2
1527  struct sockaddr sockun;
1528 #else
1529  struct sockaddr_un sockun; // ??? why not sockaddr or sockaddr_in ???
1530 #endif
1531 
1532  ckarg(1);
1533  len=sizeof(sockun);
1534  s=ckintval(argv[0]);
1535  ns=accept(s, (struct sockaddr *)&sockun, &len);
1536  if (ns<0) return(makeint(-errno));
1537  sockname=makestring((char *)&sockun,len);
1538  return(cons(ctx,makeint(ns),cons(ctx,sockname,NIL)));}
1539 
1540 /* non-connected (datagram) socket communication */
1541 /* Address must be bound to a socket at the receiver side. */
1542 /* Sender specifies the address when it calls SENDTO. */
1543 pointer SENDTO(ctx,n,argv)
1544 register context *ctx;
1545 int n;
1546 pointer argv[];
1547 /* unix: sendto(sock,msg,len,flags,to,tolen) */
1548 /* eus: (SENDTO sock addr msg [len [flags]]) */
1549 { int len, sock, flags, stat;
1550  pointer msg, addr;
1551  ckarg2(3,5);
1552  sock=ckintval(argv[0]);
1553  addr=(pointer)Getstring(argv[1]);
1554  msg=(pointer)Getstring(argv[2]);
1555  if (n>=4) len=ckintval(argv[3]); else len=vecsize(msg);
1556  if (n>=5) flags=ckintval(argv[4]); else flags=0;
1557  stat=sendto(sock, (char *)msg->c.str.chars, len, flags,
1558  (struct sockaddr *)addr->c.str.chars, vecsize(addr));
1559  if (stat<0) stat= -errno;
1560  /* returns the number of bytes actually sent*/
1561  return(makeint(stat));}
1562 
1563 pointer RECVFROM(ctx,n,argv)
1564 register context *ctx;
1565 int n;
1566 pointer argv[];
1567 /* unix: recvfrom(s,buf,len,flags,from,fromlen) */
1568 /* eus: (RECVFROM sock [msg [from [flags]]])
1569  no address is required since it has already bound to
1570  the socket */
1571 { int len=2000, sock, flags, stat, addrlen;
1572  unsigned char buf[2000], *bufp=buf, *addrp=NULL;
1573  pointer msg, addr;
1574  ckarg2(1,4);
1575  sock=ckintval(argv[0]);
1576  if (n>=2) {
1577  msg=argv[1];
1578  if (isstring(msg)) msg=(pointer)Getstring(argv[1]); /*message buffer*/
1579  else msg=makebuffer(ckintval(argv[1]));
1580  bufp=msg->c.str.chars;
1581  len=vecsize(msg);}
1582  if (n>=3) {
1583  addr=Getstring(argv[2]);
1584  addrlen=vecsize(addr);
1585  addrp=addr->c.str.chars;}
1586  if (n>=4) flags=ckintval(argv[3]); else flags=0;
1587  stat=recvfrom(sock, (char *)bufp, len, flags, (struct sockaddr *)addrp, &addrlen);
1588  if (stat<0) return(makeint(-errno));
1589  /* if the result is negative, it indicates error number,
1590  otherwise, the actual length of the message is returned. */
1591  if (n<2) return(makestring((char *)bufp,stat));
1592  else return(makeint(stat));}
1593 
1594 #if !Solaris2
1595 pointer GETPEERNAME(ctx,n,argv)
1596 register context *ctx;
1597 int n;
1598 pointer argv[];
1599 { char name[128];
1600  int namelen, stat;
1601  ckarg(1);
1602  stat=getpeername(ckintval(argv[0]), (struct sockaddr *)name, &namelen);
1603  if (stat<0) return(makeint(-errno));
1604  else return(makestring(name,namelen));}
1605 #endif
1607 #if !vxworks
1608 
1609 eusinteger_t *checkbitvec(pointer a, long *size)
1610 { if (a==NIL) { *size=0; return(0);}
1611  if (!isvector(a)) error(E_NOVECTOR);
1612  switch(elmtypeof(a)) {
1613  case ELM_BIT: *size=vecsize(a); return(a->c.ivec.iv);
1614  case ELM_INT: *size=vecsize(a) * WORD_SIZE; return(a->c.ivec.iv);
1615  case ELM_BYTE: case ELM_CHAR:
1616  *size=vecsize(a) * 8; return(a->c.ivec.iv);
1617  case ELM_FOREIGN: *size=vecsize(a) * 8; return((eusinteger_t *)a->c.foreign.chars);
1618  default: error(E_USER,(pointer)"bit-vector expected");
1619  }
1620 }
1621 
1622 pointer SELECT(ctx,n,argv)
1623 register context *ctx;
1624 int n;
1625 register pointer argv[];
1626 { register pointer a=argv[0];
1627  long i, maxwidth, width,size0, size1, size2;
1628  fd_set *readfds, *writefds, *exceptfds;
1629  eusfloat_t timeout;
1630  struct timeval to;
1631  numunion nu;
1632 
1633  ckarg(4);
1634  readfds=(fd_set *)checkbitvec(argv[0], &size0);
1635  writefds=(fd_set *)checkbitvec(argv[1], &size1);
1636  exceptfds=(fd_set *)checkbitvec(argv[2], &size2);
1637  maxwidth=min(256, max(max(size0, size1), size2));
1638 
1639 /* printf("SELECT: readfds=%x\n", readfds);
1640  printf("SELECT: writefds=%x\n", writefds);
1641  printf("SELECT: exceptfds=%x\n", exceptfds); */
1642 
1643  /* find the highest numbered fd */
1644  width=0;
1645  for (i=0; i<maxwidth; i++) {
1646  if (readfds && FD_ISSET(i, readfds)) width=i;
1647  if (writefds && FD_ISSET(i, writefds)) width=i;
1648  if (exceptfds && FD_ISSET(i, exceptfds)) width=i;}
1649  width = width + 1;
1650 
1651  timeout=ckfltval(argv[3]);
1652  if (timeout==0.0)
1653  {GC_REGION(i=select(width, readfds, writefds, exceptfds,0););}
1654  else {
1655  to.tv_sec=timeout;
1656  timeout=timeout-to.tv_sec;
1657  timeout=timeout*1000000;
1658  to.tv_usec=timeout;
1659  GC_REGION(i=select(width, readfds, writefds, exceptfds,&to);)}
1660  if (i<0) return(makeint(-errno));
1661  else return(makeint(i)); }
1662 
1663 pointer SELECT_READ(ctx,n,argv)
1664 register context *ctx;
1665 int n;
1666 pointer argv[];
1667 { struct timeval to;
1668  eusfloat_t timeout;
1669  long i, size, width, fds;
1670  fd_set *fdvec;
1671  numunion nu;
1672 
1673  ckarg(2);
1674  if (isint(argv[0])) {
1675  fds=intval(argv[0]);
1676  fdvec=(fd_set *)&fds;
1677  size=30; }
1678  else fdvec=(fd_set *)checkbitvec(argv[0], &size);
1679  size=min(256,size);
1680  for (i=0; i<size; i++) if (FD_ISSET(i, fdvec)) width=i;
1681  width = width+1;
1682 
1683  timeout=ckfltval(argv[1]);
1684  if (timeout==0.0) {GC_REGION(n=select(width, fdvec, 0, 0, 0););}
1685  else {
1686  to.tv_sec=timeout;
1687  timeout=timeout-to.tv_sec;
1688  timeout=timeout*1000000;
1689  to.tv_usec=timeout;
1690  GC_REGION(n=select(width, fdvec, 0, 0, &to););}
1691  if (n<0) return(makeint(-errno));
1692  if (isint(argv[0])) {
1693  /*fds=fdvec-> __fds_bits[0];*/
1694  /* fds_bits should be __fds_bits on some operating systems */
1695  return(makeint(fds)); }
1696  else return(argv[0]); }
1697 
1698 #endif /* !vxworks */
1699 
1700 
1701 /****************************************************************/
1702 /* physical memory allocator
1703 /* 1988-Jul
1704 /****************************************************************/
1705 pointer SBRK(ctx,n,argv)
1706 register context *ctx;
1707 int n; pointer argv[];
1708  { return(makeint((eusinteger_t)sbrk(ckintval(argv[0]))));}
1709 
1710 pointer MALLOC(ctx,n,argv)
1711 register context *ctx;
1712 int n; pointer argv[];
1713  { return(makeint((eusinteger_t)malloc(ckintval(argv[0]))));}
1714 
1715 pointer FREE(ctx,n,argv)
1716 register context *ctx;
1717 int n; pointer argv[];
1718 { free((void *)bigintval(argv[0]));
1719  return(makeint(1));}
1720 
1721 #if sun3 || sun4 || news || alpha
1722 pointer VALLOC(ctx,n,argv)
1723 register context *ctx;
1724 int n; pointer argv[];
1725 { return(makeint(valloc(ckintval(argv[0]))));}
1726 #endif
1727 
1728 #if sun3 || sun4 || news || alpha || Linux || Cygwin
1729 
1730 pointer MMAP(ctx,n,argv)
1731 register context *ctx;
1732 int n; register pointer argv[];
1733 { int fd;
1734  eusinteger_t offset,result,len;
1735  pointer strm;
1736  ckarg(6);
1737  strm=argv[4];
1738  if (isiostream(strm)) strm=strm->c.iostream.in;
1739  if (isfilestream(strm)) fd=intval(strm->c.fstream.fd);
1740  else fd=ckintval(strm);
1741  len=ckintval(argv[1]);
1742  if (isintvector(argv[5]))
1743  offset=((argv[5]->c.ivec.iv[0])<<16) + argv[5]->c.ivec.iv[1];
1744  else offset=ckintval(argv[5]);
1745  result=(eusinteger_t)mmap((caddr_t)ckintval(argv[0]), len,
1746  ckintval(argv[2]), ckintval(argv[3]), fd, offset);
1747  if (result== -1) return(makeint(-errno));
1748  else return((pointer)make_foreign_string(result, len));}
1749 
1750 pointer MUNMAP(ctx,n,argv)
1751 register context *ctx;
1752 int n; pointer argv[];
1753 { return(makeint(munmap((caddr_t)ckintval(argv[0]),ckintval(argv[1]))));}
1754 
1755 /*
1756 pointer VADVISE(ctx,n,argv)
1757 register context *ctx;
1758 int n; pointer argv[];
1759 { n=vadvise(ckintval(argv[0]));
1760  if (n==0) return(T); else return(makeint(errno));}
1761 */
1762 
1763 #endif
1764 
1765 /****************************************************************/
1766 /* network library routines
1767 /****************************************************************/
1768 #if !vxworks
1769 
1770 pointer GETHOSTNAME(ctx,n,argv)
1771 register context *ctx;
1772 int n; pointer argv[];
1773 { char buf[32]; int stat;
1774  stat=gethostname(buf,32);
1775  if (stat==0) return(makestring(buf,strlen(buf)));
1776  else return(makeint(errno));}
1777 
1778 pointer GETHOSTBYNAME(ctx,n,argv)
1779 register context *ctx;
1780 int n;
1781 register pointer *argv;
1782 { register struct hostent *hp;
1783  register pointer s;
1784 
1785  ckarg(1);
1786  hp=gethostbyname((char *)Getstring(argv[0])->c.str.chars);
1787  if (hp==NULL) return(makeint(-errno));
1788  s=cons(ctx,makeint(hp->h_addrtype),NIL);
1789  s=cons(ctx,makestring(hp->h_addr,hp->h_length),s);
1790  return(s);} /*list of 32bit address and address type*/
1791 
1792 pointer GETHOSTBYADDR(ctx,n,argv)
1793 register context *ctx;
1794 int n;
1795 pointer *argv;
1796 { pointer addr;
1797  struct hostent *host;
1798  ckarg(1);
1799  addr=Getstring(argv[0]);
1800  host=gethostbyaddr((char *)addr->c.str.chars, vecsize(addr), 2);
1801  if (host==NULL) return(makeint(-errno));
1802  else return(makestring(host->h_name, strlen(host->h_name)));}
1803 
1804 #if !Cygwin /* Cygwin does not hvae getnetbyname */
1805 pointer GETNETBYNAME(ctx,n,argv)
1806 register context *ctx;
1807 int n;
1808 register pointer *argv;
1809 { struct netent *np;
1810  ckarg(1);
1811  np=getnetbyname((char *)Getstring(argv[0])->c.str.chars);
1812  if (np==NULL) return(makeint(-errno));
1813  return(cons(ctx,makeint(np->n_net),
1814  cons(ctx,makeint(np->n_addrtype),NIL)));}
1815 #endif
1816 
1817 pointer GETPROTOBYNAME(ctx,n,argv)
1818 register context *ctx;
1819 int n;
1820 register pointer *argv;
1821 { struct protoent *pp;
1822  ckarg(1);
1823  pp=getprotobyname((char *)Getstring(argv[0])->c.str.chars);
1824  if (pp==NULL) return(makeint(-errno));
1825  return(makeint(pp->p_proto));}
1826 
1827 pointer GETSERVBYNAME(ctx,n,argv)
1828 register context *ctx;
1829 int n;
1830 register pointer *argv;
1831 { struct servent *sp;
1832  pointer s;
1833  byte *p;
1834  long int port;
1835 
1836  ckarg2(1,2);
1837  if (n==2 && argv[1]!=NIL) p=Getstring(argv[1])->c.str.chars;
1838  else p=NULL;
1839  sp=getservbyname((char *)Getstring(argv[0])->c.str.chars,(char *)p);
1840  if (sp==NULL) return(makeint(-errno));
1841  s=makestring(sp->s_proto,strlen(sp->s_proto));
1842  vpush(s);
1843  port = ntohs(sp->s_port);
1844  s=cons(ctx,makeint(port),cons(ctx,s,NIL));
1845  vpop();
1846  return(s);}
1847 
1848 /* Append by I.Hara for IPC */
1849 /* htons -- convert values between host and network byte order */
1850 pointer H2NS(ctx,n,argv)
1851 register context *ctx;
1852 int n;
1853 register pointer *argv;
1854 { int hostshort;
1855  unsigned short netshort;
1856  ckarg(1);
1857  hostshort=ckintval(argv[0]);
1858  netshort=htons((short)hostshort);
1859  return(makeint(netshort));}
1860 
1861 pointer N2HS(ctx,n,argv)
1862 register context *ctx;
1863 int n;
1864 register pointer *argv;
1865 { int hostshort;
1866  unsigned short netshort;
1867  ckarg(1);
1868  netshort=ckintval(argv[0]);
1869  hostshort=ntohs((short)netshort);
1870  return(makeint(hostshort));}
1871 
1872 #endif
1873 
1874 
1875 
1876 
1877 #ifdef DBM
1878 /* ndbm --- data base
1879  1988-May
1880  (c) T.Matsui
1881 */
1882 
1883 #if sun3 || sun4
1884 
1885 #include <ndbm.h>
1886 
1887 pointer DBM_OPEN(ctx,n,argv)
1888 register context *ctx;
1889 int n;
1890 register pointer argv[];
1891 { DBM *dbm;
1892  ckarg(3);
1893  dbm=dbm_open(Getstring(argv[0])->c.str.chars,
1894  ckintval(argv[1]),
1895  ckintval(argv[2]));
1896  return(makeint(dbm));}
1897 
1898 pointer DBM_CLOSE(ctx,n,argv)
1899 register context *ctx;
1900 int n;
1901 register pointer argv[];
1902 { ckarg(1);
1903  dbm_close(ckintval(argv[0]));
1904  return(T);}
1905 
1906 pointer DBM_FETCH(ctx,n,argv)
1907 register context *ctx;
1908 int n;
1909 register pointer argv[];
1910 { register pointer s;
1911  datum key,content;
1912  ckarg(2);
1913  s=Getstring(argv[1]);
1914  key.dptr=(char *)(s->c.str.chars);
1915  key.dsize=strlength(s);
1916  content=dbm_fetch(ckintval(argv[0]), key);
1917  if (content.dptr==NULL) return(NIL);
1918  return(makestring(content.dptr,content.dsize));}
1919 
1920 pointer DBM_STORE(ctx,n,argv)
1921 register context *ctx;
1922 int n;
1923 register pointer argv[];
1924 { register pointer s;
1925  datum key,content;
1926  ckarg(4);
1927  s=Getstring(argv[1]);
1928  key.dptr=(char *)s->c.str.chars;
1929  key.dsize=strlength(s);
1930  s=Getstring(argv[2]);
1931  content.dptr=(char *)s->c.str.chars;
1932  content.dsize=strlength(s);
1933  n=dbm_store(ckintval(argv[0]), key, content, ckintval(argv[3]));
1934  return((n==0)?T:NIL);}
1935 
1936 pointer DBM_DELETE(ctx,n,argv)
1937 register context *ctx;
1938 int n;
1939 register pointer argv[];
1940 { register pointer s;
1941  datum key;
1942  ckarg(2);
1943  s=Getstring(argv[1]);
1944  key.dptr=(char *)s->c.str.chars;
1945  key.dsize=strlength(s);
1946  n=dbm_delete(ckintval(argv[0]), key);
1947  return((n==0)?T:NIL);}
1948 
1949 pointer DBM_FIRSTKEY(ctx,n,argv)
1950 register context *ctx;
1951 int n;
1952 register pointer argv[];
1953 { datum key;
1954  ckarg(1);
1955  key=dbm_firstkey(ckintval(argv[0]), key);
1956  if (key.dptr==NULL) return(NIL);
1957  return(makestring(key.dptr,key.dsize));}
1958 
1959 pointer DBM_NEXTKEY(ctx,n,argv)
1960 register context *ctx;
1961 int n;
1962 register pointer argv[];
1963 { datum key;
1964  ckarg(1);
1965  key=dbm_nextkey(ckintval(argv[0]), key);
1966  if (key.dptr==NULL) return(NIL);
1967  return(makestring(key.dptr,key.dsize));}
1968 
1969 pointer DBM_ERROR(ctx,n,argv)
1970 register context *ctx;
1971 int n;
1972 register pointer argv[];
1973 { ckarg(1);
1974  n=dbm_error((DBM *)ckintval(argv[0]));
1975  return((n==0)?T:NIL);}
1976 
1977 pointer DBM_CLEARERR(ctx,n,argv)
1978 register context *ctx;
1979 int n;
1980 register pointer argv[];
1981 { ckarg(1);
1982  dbm_clearerr((DBM *)ckintval(argv[0]));
1983  return(T);}
1984 
1985 #endif /*sun3 || sun4*/
1986 #endif /*ifdef DBM*/
1987 
1988 
1989 /* initialization of unixcall functions*/
1990 void unixcall(ctx,mod)
1991 register context *ctx;
1992 pointer mod;
1993 { pointer p=Spevalof(PACKAGE);
1994 
1995  Spevalof(PACKAGE)=unixpkg;
1996 
1997 /* common to unix and to vxworks */
1998  defun(ctx,"SIGADDSET",mod,SIGADDSET,NULL);
1999  defun(ctx,"SIGDELSET",mod,SIGDELSET,NULL);
2000  defun(ctx,"SIGPROCMASK",mod,SIGPROCMASK,NULL);
2001  defun(ctx,"KILL",mod,KILL,NULL);
2002  defun(ctx,"SIGNAL",mod,SIGNAL,NULL);
2003  defun(ctx,"EXIT",mod,EXIT,NULL);
2004  defun(ctx,"_EXIT",mod,_EXIT,NULL);
2005  defun(ctx,"GETPID",mod,GETPID,NULL);
2006  defun(ctx,"UREAD",mod,UNIXREAD,NULL);
2007  defun(ctx,"WRITE",mod,UNIXWRITE,NULL);
2008  defun(ctx,"UCLOSE",mod,UNIXCLOSE,NULL);
2009  defun(ctx,"IOCTL",mod,IOCTL,NULL);
2010  defun(ctx,"LSEEK",mod,LSEEK,NULL);
2011  defun(ctx,"SBRK",mod,SBRK,NULL);
2012  defun(ctx,"MALLOC",mod,MALLOC,NULL);
2013  defun(ctx,"FREE",mod,FREE,NULL);
2014 
2015  defun(ctx,"SOCKET",mod,SOCKET,NULL);
2016  defun(ctx,"BIND",mod,BIND,NULL);
2017  defun(ctx,"CONNECT",mod,CONNECT,NULL);
2018  defun(ctx,"LISTEN",mod,LISTEN,NULL);
2019  defun(ctx,"ACCEPT",mod,ACCEPT,NULL);
2020  defun(ctx,"SENDTO",mod,SENDTO,NULL);
2021  defun(ctx,"RECVFROM",mod,RECVFROM,NULL);
2022 #if !Solaris2
2023  defun(ctx,"GETPEERNAME",mod,GETPEERNAME,NULL);
2024 #endif
2025 /* #endif /*socket*/
2026 
2027 /*not supported by vxworks*/
2028 #if !vxworks
2029  defun(ctx,"PTIMES",mod,PTIMES,NULL);
2030  defun(ctx,"RUNTIME",mod,RUNTIME,NULL);
2031  defun(ctx,"LOCALTIME",mod,LOCALTIME,NULL);
2032  defun(ctx,"ASCTIME",mod,ASCTIME,NULL);
2033  defun(ctx,"GETITIMER",mod,GETITIMER,NULL);
2034  defun(ctx,"SETITIMER",mod,SETITIMER,NULL);
2035 
2036 #if !Solaris2
2037  defun(ctx,"GETRUSAGE",mod,GETRUSAGE,NULL);
2038  defun(ctx,"GETPAGESIZE",mod,GETPAGESIZE,NULL);
2039 #endif
2040 
2041  defun(ctx,"GETTIMEOFDAY",mod,GETTIMEOFDAY,NULL);
2042  defun(ctx,"ALARM",mod,ALARM,NULL);
2043 
2044 #if sun3 || sun4 || news || sanyo || alpha || x86_64 || ARM /* why i386 does not exist? */
2045 #if !Solaris2
2046  defun(ctx,"UALARM",mod,UALARM,NULL);
2047 #endif
2048 #endif
2049 
2050  defun(ctx,"WAIT",mod,WAIT,NULL);
2051  defun(ctx,"FORK",mod,FORK,NULL);
2052 #if Solaris2
2053  defun(ctx,"FORK1",mod,FORK1,NULL);
2054 #endif
2055  defun(ctx,"GETPPID",mod,GETPPID,NULL);
2056  defun(ctx,"GETPGRP",mod,GETPGRP,NULL);
2057  defun(ctx,"SETPGRP",mod,SETPGRP,NULL);
2058  defun(ctx,"GETUID",mod,GETUID,NULL);
2059  defun(ctx,"GETEUID",mod,GETEUID,NULL);
2060  defun(ctx,"GETGID",mod,GETGID,NULL);
2061  defun(ctx,"GETEGID",mod,GETEGID,NULL);
2062  defun(ctx,"SETUID",mod,SETUID,NULL);
2063  defun(ctx,"SETGID",mod,SETGID,NULL);
2064  defun(ctx,"MKNOD",mod,MKNOD,NULL);
2065  defun(ctx,"MKDIR",mod,MKDIR,NULL);
2066 #if !Cygwin /* Cygwin does not have LOCKF */
2067  defun(ctx,"LOCKF",mod,LOCKF,NULL);
2068 #endif
2069  defun(ctx,"FCNTL",mod,FCNTL,NULL);
2070 #if !Solaris2
2071  defun(ctx,"IOCTL_",mod,IOCTL_,NULL);
2072  defun(ctx,"IOCTL_R",mod,IOCTL_R,NULL);
2073  defun(ctx,"IOCTL_W",mod,IOCTL_W,NULL);
2074 #if !Cygwin /* Cygwin does not have IOCTL_WR */
2075  defun(ctx,"IOCTL_WR",mod,IOCTL_WR,NULL);
2076 #endif
2077 #endif
2078  defun(ctx,"DUP",mod,DUP,NULL);
2079  defun(ctx,"DUP2",mod,DUP2,NULL);
2080  defun(ctx,"SYSTEM",mod,SYSTEM,NULL);
2081  defun(ctx,"GETWD",mod,GETWD,NULL);
2082  defun(ctx,"GETENV",mod,GETENV,NULL);
2083  defun(ctx,"ENVIRON",mod,ENVIRON,NULL);
2084  defun(ctx,"SLEEP",mod,SLEEP,NULL);
2085  defun(ctx,"ERRNO",mod,ERRNO,NULL);
2086  defun(ctx,"PERROR",mod,PERROR,NULL);
2087  defun(ctx,"SYSERRLIST",mod,SYSERRLIST,NULL);
2088  defun(ctx,"PAUSE",mod,PAUSE,NULL);
2089  defun(ctx,"ISATTY",mod,ISATTY,NULL);
2090  defun(ctx,"LINK",mod,LINK,NULL);
2091  defun(ctx,"UNLINK",mod,UNLINK,NULL);
2092  defun(ctx,"RMDIR",mod,RMDIR,NULL);
2093  defun(ctx,"RENAME",mod,RENAME,NULL);
2094  defun(ctx,"ACCESS",mod,ACCESS,NULL);
2095 /* defun(ctx,"FLOCK",mod,FLOCK,NULL); */
2096  defun(ctx,"STAT",mod,STAT,NULL);
2097  defun(ctx,"CHDIR",mod,CHDIR,NULL);
2098  defun(ctx,"CHMOD",mod,CHMOD,NULL);
2099  defun(ctx,"CHOWN",mod,CHOWN,NULL);
2100  defun(ctx,"PIPE",mod,PIPE,NULL);
2101  defun(ctx,"SELECT",mod,SELECT,NULL);
2102  defun(ctx,"SELECT-READ-FD",mod,SELECT_READ,NULL);
2103  defun(ctx,"READDIR",mod,DIRECTORY,NULL);
2104 
2105 #if !vxworks
2106  defun(ctx,"GETHOSTNAME",mod,GETHOSTNAME,NULL);
2107  defun(ctx,"GETHOSTBYNAME",mod,GETHOSTBYNAME,NULL);
2108  defun(ctx,"GETHOSTBYADDR",mod,GETHOSTBYADDR,NULL);
2109 #if !Cygwin /* Cygwin does not have GETNETBYNMAE */
2110  defun(ctx,"GETNETBYNAME",mod,GETNETBYNAME,NULL);
2111 #endif
2112  defun(ctx,"GETPROTOBYNAME",mod,GETPROTOBYNAME,NULL);
2113  defun(ctx,"GETSERVBYNAME",mod,GETSERVBYNAME,NULL);
2114 /* Append by I.Hara for IPC */
2115  defun(ctx,"HTONS",mod,H2NS,NULL);
2116  defun(ctx,"NTOHS",mod,N2HS,NULL);
2117 #endif
2118 
2119 #if sun3 || sun4 || vax || news || sanyo || (mips && !IRIX && !IRIX6) || i386 || alpha || x86_64 || ARM
2120  defun(ctx,"VFORK",mod,VFORK,NULL);
2121 #endif
2122  defun(ctx,"EXEC",mod,EXEC,NULL);
2123 #if !Solaris2 && !Cygwin
2124  defun(ctx,"GETPRIORITY",mod,GETPRIORITY,NULL);
2125  defun(ctx,"SETPRIORITY",mod,SETPRIORITY,NULL);
2126 #endif
2127 
2128 #if sun3 || sun4 || vax || mips || i386 || alpha || x86_64 || ARM
2129  defun(ctx,"PUTENV",mod,PUTENV,NULL);
2130 #endif
2131 #if sun3 || sun4 && !Solaris2 || Linux || alpha || Cygwin
2132  defun(ctx,"USLEEP",mod,USLEEP,NULL);
2133 #endif
2134 
2135 #if !news
2136  defun(ctx,"MSGGET",mod,MSGGET,NULL);
2137  defun(ctx,"MSGSND",mod,MSGSND,NULL);
2138  defun(ctx,"MSGRCV",mod,MSGRCV,NULL);
2139  defun(ctx,"MSGCTL",mod,MSGCTL,NULL);
2140 #endif
2141 
2142 #if sun3 || sun4 || news || alpha
2143  defun(ctx,"VALLOC",mod,VALLOC,NULL);
2144 #endif
2145 #if sun3 || sun4 || news || alpha || Linux || Cygwin
2146  defun(ctx,"MMAP",mod,MMAP,NULL);
2147  defun(ctx,"MUNMAP",mod,MUNMAP,NULL);
2148 /* defun(ctx,"VADVISE",mod,VADVISE,NULL); */
2149 #endif
2150 
2151 #if system5 || Linux || Cygwin
2152  defun(ctx,"UNAME",mod,UNAME,NULL);
2153 #endif
2154 
2155 #endif /*socket*/
2156 
2157 /*ndbm libraries*/
2158 #ifdef DBM
2159 #if sun3 || sun4
2160  defun(ctx,"DBM-OPEN",mod,DBM_OPEN,NULL);
2161  defun(ctx,"DBM-CLOSE",mod,DBM_CLOSE,NULL);
2162  defun(ctx,"DBM-FETCH",mod,DBM_FETCH,NULL);
2163  defun(ctx,"DBM-STORE",mod,DBM_STORE,NULL);
2164  defun(ctx,"DBM-DELETE",mod,DBM_DELETE,NULL);
2165  defun(ctx,"DBM-FIRSTKEY",mod,DBM_FIRSTKEY,NULL);
2166  defun(ctx,"DBM-NEXTKEY",mod,DBM_NEXTKEY,NULL);
2167  defun(ctx,"DBM-ERROR",mod,DBM_ERROR,NULL);
2168  defun(ctx,"DBM-CLEARERR",mod,DBM_CLEARERR,NULL);
2169 #endif
2170 
2171 #endif
2172 /* restore package*/ pointer_update(Spevalof(PACKAGE),p);
2173 }
pointer K_IN
Definition: eus.c:130
context * euscontexts[MAXTHREAD]
Definition: eus.c:105
static char buf[CHAR_SIZE]
eusinteger_t iv[1]
Definition: eus.h:303
pointer IOCTL_(context *, int, pointer *)
pointer GETITIMER(context *ctx, int n, argv)
Definition: unixcall.c:252
pointer N2HS(context *, int, pointer *)
f
pointer GETENV(context *, int, pointer *)
pointer SETPGRP(context *, int, pointer *)
pointer PAUSE(context *, int, pointer *)
struct vector vec
Definition: eus.h:412
pointer RMDIR(context *, int, pointer *)
pointer UNIXWRITE(context *, int, pointer *)
pointer SIGNAL(context *ctx, int n, argv)
Definition: unixcall.c:364
pointer UNIXCLOSE(context *, int, pointer *)
pointer ACCESS(context *, int, pointer *)
static void * parent(void)
Definition: unixcall.c:594
#define makeint(v)
Definition: sfttest.c:2
struct cell * pointer
Definition: eus.h:163
pointer LOCKF(context *, int, pointer *)
pointer DBM_CLOSE(context *ctx, int n, argv)
Definition: ndbm.c:21
pointer C_VECTOR
Definition: eus.c:144
pointer UALARM(context *ctx, int n, argv)
Definition: unixcall.c:453
pointer K_OUT
Definition: eus.c:130
pointer FCNTL(context *, int, pointer *)
Definition: eus.h:522
pointer SBRK(context *, int, pointer *)
pointer cons(context *, pointer, pointer)
Definition: makes.c:97
static pointer GETPRIORITY(context *ctx, int n, pointer *argv)
Definition: unixcall.c:661
struct filestream fstream
Definition: eus.h:404
pointer EXEC(context *ctx, int n, pointer *argv)
Definition: unixcall.c:634
pointer mkfilestream(context *, pointer, pointer, int, pointer)
Definition: makes.c:253
pointer MSGCTL(context *, int, pointer *)
struct string str
Definition: eus.h:400
pointer GETHOSTBYNAME(context *, int, pointer *)
int thr_continue(int)
Definition: pthreads.c:58
pointer unixpkg
Definition: eus.c:109
struct threadport thrp
Definition: eus.h:419
byte chars[1]
Definition: eus.h:210
pointer DBM_STORE(context *ctx, int n, argv)
Definition: ndbm.c:43
pointer * vsp
Definition: eus.h:523
pointer Getstring()
pointer GETPAGESIZE(context *ctx, int n, argv)
Definition: unixcall.c:225
pointer SENDTO(context *, int, pointer *)
Definition: eus.h:193
pointer T
Definition: eus.c:110
GLfloat n[6][3]
Definition: cube.c:15
pointer PUTENV(context *, int, pointer *)
pointer SIGADDSET(context *ctx, int n, argv)
Definition: unixcall.c:303
pointer RECVFROM(context *, int, pointer *)
pointer SYSERRLIST(context *, int, pointer *)
pointer MKDIR(context *, int, pointer *)
byte * chars
Definition: eus.h:214
pointer GETPGRP(context *ctx, int n, argv)
Definition: unixcall.c:482
pointer ASCTIME(context *ctx, int n, argv)
Definition: unixcall.c:171
pointer H2NS(context *, int, pointer *)
pointer GETEUID(context *ctx, int n, argv)
Definition: unixcall.c:510
int daylight
pointer MSGGET(context *, int, pointer *)
pointer SIGDELSET(context *ctx, int n, argv)
Definition: unixcall.c:319
struct foreign foreign
Definition: eus.h:401
#define intval(p)
Definition: sfttest.c:1
long tv_sec
Definition: posix.c:11
defun("ADR_TO_STRING", mod, ADR_TO_STRING)
eusinteger_t * checkbitvec(pointer, long *)
pointer ufuncall(context *, pointer, pointer, pointer, struct bindframe *, int)
Definition: eval.c:1208
char * tzname[2]
pointer DUP2(context *, int, pointer *)
pointer MKNOD(context *, int, pointer *)
pointer LINK(context *, int, pointer *)
pointer MSGSND(context *, int, pointer *)
pointer KILL(context *ctx, int n, argv)
Definition: unixcall.c:356
pointer LISTEN(context *, int, pointer *)
Definition: eus.h:1002
pointer makevector(pointer, int)
Definition: makes.c:417
pointer PTIMES(context *ctx, int n, argv)
Definition: unixcall.c:102
ckarg(2)
pointer GETEGID(context *ctx, int n, argv)
Definition: unixcall.c:524
float ckfltval()
pointer GETSERVBYNAME(context *, int, pointer *)
pointer RENAME(context *, int, pointer *)
#define min(x, y)
Definition: rmflags.c:17
pointer DBM_OPEN(context *ctx, int n, argv)
Definition: ndbm.c:10
pointer DBM_NEXTKEY(context *ctx, int n, argv)
Definition: ndbm.c:82
pointer FORK(context *ctx, int n, pointer *argv)
Definition: unixcall.c:572
pointer GETHOSTNAME(context *, int, pointer *)
static void key(unsigned char c, int x, int y)
Definition: dinoshade.c:753
struct intvector ivec
Definition: eus.h:414
pointer FORK1(context *ctx, int n, pointer *argv)
Definition: unixcall.c:616
pointer GETGID(context *ctx, int n, argv)
Definition: unixcall.c:517
union cell::cellunion c
pointer out
Definition: eus.h:289
pointer VFORK(context *ctx, int n, pointer *argv)
Definition: unixcall.c:626
int errno
pointer ENVIRON(context *, int, pointer *)
pointer MALLOC(context *, int, pointer *)
long tv_nsec
Definition: posix.c:12
pointer CHMOD(context *, int, pointer *)
pointer GETNETBYNAME(context *, int, pointer *)
pointer IOCTL_R(context *, int, pointer *)
Definition: eus.h:426
struct stream stream
Definition: eus.h:403
pointer GETUID(context *ctx, int n, pointer *argv)
Definition: unixcall.c:506
long l
Definition: structsize.c:3
pointer mkiostream(context *, pointer, pointer)
Definition: makes.c:269
pointer RUNTIME(context *ctx, int n, argv)
Definition: unixcall.c:118
pointer ERRNO(context *, int, pointer *)
int thr_suspend(int)
Definition: pthreads.c:64
static void * child(void)
Definition: unixcall.c:602
Definition: eus.h:379
pointer fname
Definition: eus.h:285
void unixcall(context *, pointer)
pointer GETRUSAGE(context *ctx, int n, argv)
Definition: unixcall.c:205
static pointer SETPRIORITY(context *ctx, int n, pointer *argv)
Definition: unixcall.c:649
pointer USLEEP(context *, int, pointer *)
static char me[3]
short s
Definition: structsize.c:2
pointer CHDIR(context *, int, pointer *)
pointer SETITIMER(context *ctx, int n, argv)
Definition: unixcall.c:268
pointer GETWD(context *, int, pointer *)
pointer IOCTL_W(context *, int, pointer *)
pointer makebuffer(int)
Definition: makes.c:140
pointer SELECT_READ(context *, int, pointer *)
pointer IOCTL(context *, int, pointer *)
pointer PIPE(context *, int, pointer *)
static char * rcsid
Definition: unixcall.c:13
pointer SIGPROCMASK(context *ctx, int n, argv)
Definition: unixcall.c:335
pointer GETHOSTBYADDR(context *, int, pointer *)
eusinteger_t coerceintval(pointer)
Definition: sequence.c:55
pointer SETGID(context *ctx, int n, argv)
Definition: unixcall.c:539
pointer error(enum errorcode ec,...) pointer error(va_alist) va_dcl
Definition: eus.c:297
pointer GETPID(context *ctx, int n, pointer *argv)
Definition: unixcall.c:467
long eusinteger_t
Definition: eus.h:19
pointer SETUID(context *ctx, int n, argv)
Definition: unixcall.c:531
pointer QEXITHOOK
Definition: eus.c:122
pointer SYSTEM(context *, int, pointer *)
pointer DBM_FETCH(context *ctx, int n, argv)
Definition: ndbm.c:29
pointer DBM_FIRSTKEY(context *ctx, int n, argv)
Definition: ndbm.c:72
pointer DIRECTORY(context *, int, pointer *)
pointer buffer
Definition: eus.h:281
byte * get_string()
pointer UNLINK(context *, int, pointer *)
pointer PACKAGE
Definition: eus.c:110
pointer direction
Definition: eus.h:273
pointer UNIXREAD(context *ctx, int n, argv)
Definition: unixcall.c:704
pointer stacknlist(context *, int)
Definition: makes.c:129
pointer GETPEERNAME(context *, int, pointer *)
pointer ISATTY(context *, int, pointer *)
#define GC_REGION(cmp_statement)
Definition: eus.h:171
pointer MMAP(context *, int, pointer *)
pointer SELECT(context *, int, pointer *)
static int ctxid_in_child
Definition: unixcall.c:582
pointer ACCEPT(context *, int, pointer *)
pointer FREE(context *, int, pointer *)
pointer LOCALTIME(context *ctx, int n, argv)
Definition: unixcall.c:127
time_t altzone
static void * prepare(void)
Definition: unixcall.c:583
void eusint(int s, int code, int x, eusinteger_t addr)
Definition: eus.c:954
int count
Definition: thrtest.c:11
pointer _EXIT(context *ctx, int n, pointer *argv)
Definition: unixcall.c:691
pointer makestring(char *, int)
Definition: makes.c:147
pointer tail
Definition: eus.h:276
pointer MSGRCV(context *, int, pointer *)
pointer CHOWN(context *, int, pointer *)
#define max(I1, I2)
Definition: eustags.c:134
pointer DUP(context *, int, pointer *)
pointer DBM_ERROR(context *ctx, int n, argv)
Definition: ndbm.c:92
#define NULL
Definition: transargv.c:8
struct iostream iostream
Definition: eus.h:405
pointer EXIT(context *ctx, int n, pointer *argv)
Definition: unixcall.c:671
pointer LSEEK(context *, int, pointer *)
pointer WAIT(context *ctx, int n, argv)
Definition: unixcall.c:435
pointer fd
Definition: eus.h:284
pointer IOCTL_WR(context *, int, pointer *)
pointer SOCKET(context *, int, pointer *)
pointer make_foreign_string(eusinteger_t, int)
Definition: makes.c:157
pointer count
Definition: eus.h:275
Definition: posix.c:10
time_t timezone
Definition: eus.h:950
pointer in
Definition: eus.h:289
unsigned char byte
Definition: eus.h:161
pointer eussigvec[NSIG]
Definition: eus.c:182
unsigned int thr_self()
Definition: eus.c:25
pointer BIND(context *, int, pointer *)
double eusfloat_t
Definition: eus.h:20
eusinteger_t mypid
Definition: eus.c:38
pointer ALARM(context *ctx, int n, argv)
Definition: unixcall.c:444
pointer CONNECT(context *, int, pointer *)
pointer NIL
Definition: eus.c:110
pointer GETTIMEOFDAY(context *ctx, int n, argv)
Definition: unixcall.c:233
pointer SLEEP(context *, int, pointer *)
pointer GETPPID(context *ctx, int n, argv)
Definition: unixcall.c:475
pointer v[1]
Definition: eus.h:299
pointer MUNMAP(context *, int, pointer *)
pointer DBM_DELETE(context *ctx, int n, argv)
Definition: ndbm.c:59
static int sock
pointer threadobj
Definition: eus.h:536
if(n==1)
Definition: unixcall.c:491
Definition: eus.h:952
char a[26]
Definition: freq.c:4
pointer length
Definition: eus.h:209
pointer GETPROTOBYNAME(context *, int, pointer *)
pointer STAT(context *, int, pointer *)
pointer UNAME(context *ctx, int n, pointer *argv)
Definition: unixcall.c:550
pointer makeflt()
int bytesize(pointer)
pointer DBM_CLEARERR(context *ctx, int n, argv)
Definition: ndbm.c:100


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Jun 6 2019 20:00:44