unixcall.c
Go to the documentation of this file.
00001 /****************************************************************/
00002 /* unixcall.c
00003 /*      1986-Jul-6      original for Ustation
00004 /*      1986-Dec        process id's, file changes, syserrlist
00005 /*      1987-Feb        dup,isatty
00006 /*      1987-Apr        getwd,stat,time
00007 /*      1988-Jan,Feb    socket, select
00008 /*      1988-Dec        ioctl           
00009 /*      1990-Mar        VxWorks
00010 /*      Copyright(c) 1988 MATSUI Toshihiro, Electrotechnical Laboratory.
00011 /****************************************************************/
00012 
00013 static char *rcsid="@(#)$Id$";
00014 
00015 /* SunOS's gettimeofday used to accept only one argument.
00016 #ifdef Solaris2
00017 #define _SVID_GETTOD
00018 #endif
00019 */
00020 
00021 #include "eus.h"
00022 
00023 #if vxworks
00024 #define NSIG NUM_SIGNALS
00025 #define SIG_DFL 0
00026 #include <sigLib.h>
00027 #include <socket.h>
00028 #include <in.h>
00029 #else
00030 #include <sys/types.h>
00031 #include <sys/times.h>
00032 #include <sys/stat.h>
00033 #include <signal.h>
00034 #include <sys/ioctl.h>
00035 #include <time.h>
00036 #include <sys/time.h>
00037 #include <sys/socket.h>
00038 #include <sys/un.h>
00039 #include <netinet/in.h>
00040 #include <netdb.h>
00041 #include <sys/mman.h>
00042 #include <string.h>
00043 #include <unistd.h>             /* for lseek */
00044 #endif
00045 
00046 /*SONY/news doesn't have message queu ipc facilities*/
00047 #if !vxworks
00048 #include <sys/ipc.h>
00049 #include <sys/msg.h>
00050 #endif
00051 
00052 #if SunOS4_1 || (mips && !IRIX && !IRIX6)
00053 /* Sun likes to change ioccom constants frequently. */
00054 #define IOC_VOID   _IOC_VOID
00055 #define IOC_IN     _IOC_IN
00056 #define IOC_OUT    _IOC_OUT
00057 #define IOC_INOUT  _IOC_INOUT
00058 #endif
00059 
00060 #if Linux
00061 #define IOC_VOID 0
00062 #endif
00063 
00064 #if Solaris2 || Linux || alpha || Cygwin
00065 #include <errno.h>
00066 #include <dirent.h>
00067 #else
00068 extern int errno;
00069 #endif
00070 
00071 #if Linux
00072 #define IOC_VOID 0
00073 #endif
00074 
00075 
00076 #if alpha
00077 #include <sys/utsname.h>
00078 #include <sys/types.h>
00079 #include <sys/ipc.h>
00080 #include <sys/msg.h>
00081 #endif
00082 
00083 #if system5 || Linux || Cygwin
00084 #include <sys/utsname.h>
00085 #endif
00086 
00087 #include <time.h>
00088 //extern char *tzname[2];
00089 #if !Cygwin /* extern timezone */
00090 extern time_t timezone, altzone;        /*long*/
00091 #endif
00092 extern int daylight;
00093 
00094 extern pointer eussigvec[NSIG];
00095 
00096 extern eusinteger_t coerceintval(pointer);
00097 
00098 
00099 /***************** times and status *****************/
00100 
00101 #if !vxworks
00102 pointer PTIMES(ctx,n,argv)
00103 register context *ctx;
00104 int n;
00105 pointer argv[];
00106 { struct tms buffer;
00107   register pointer t;
00108   long et;
00109   ckarg(0);
00110   GC_REGION(et=times(&buffer););
00111   t=cons(ctx,makeint(buffer.tms_cstime),NIL);
00112   t=cons(ctx,makeint(buffer.tms_cutime),t);
00113   t=cons(ctx,makeint(buffer.tms_stime),t);
00114   t=cons(ctx,makeint(buffer.tms_utime),t);
00115   t=cons(ctx,mkbigint(et),t);
00116   return(t);}
00117 
00118 pointer RUNTIME(ctx,n,argv)
00119 register context *ctx;
00120 int n;
00121 pointer argv[];
00122 { struct tms buffer;
00123   ckarg(0);
00124   GC_REGION(times(&buffer););
00125   return(makeint(buffer.tms_utime+buffer.tms_stime));}
00126 
00127 pointer LOCALTIME(ctx,n,argv)
00128 register context *ctx;
00129 int n;
00130 pointer argv[];
00131 { long clock;
00132   struct tm *tms;
00133   pointer timevec;
00134   pointer *tv;
00135   pointer tz0, tz1, tz;
00136   struct tm res;
00137 
00138   if (n==1) clock=coerceintval(argv[0]);
00139   else clock=time(0);
00140   tms=localtime_r((time_t *)&clock,&res); /* localtime-->localtime_r */
00141   timevec=makevector(C_VECTOR,10);
00142   vpush(timevec);
00143 
00144 #ifdef Cygwin
00145   if (getenv("TZ")==NULL) {
00146     tzname[0]="UTC";
00147     tzname[1]="UTC";
00148   }
00149 #endif
00150 
00151   tz0=makestring(tzname[0],strlen(tzname[0]));
00152   vpush(tz0);
00153   tz1=makestring(tzname[1],strlen(tzname[1]));
00154   vpush(tz1);
00155   tz=cons(ctx, tz1, NIL);
00156   tz=cons(ctx, tz0, tz);
00157   tv=timevec->c.vec.v;
00158   tv[0]=makeint(tms->tm_sec); 
00159   tv[1]=makeint(tms->tm_min);
00160   tv[2]=makeint(tms->tm_hour);
00161   tv[3]=makeint(tms->tm_mday);
00162   tv[4]=makeint(tms->tm_mon); 
00163   tv[5]=makeint(tms->tm_year);
00164   tv[6]=makeint(tms->tm_wday);
00165   tv[7]=makeint(tms->tm_yday);
00166   tv[8]=(tms->tm_isdst>0)?T:NIL;
00167   tv[9]=tz;
00168   vpop(); vpop(); vpop();
00169   return(timevec);}
00170 
00171 pointer ASCTIME(ctx,n,argv)
00172 register context *ctx;
00173 int n;
00174 register pointer argv[];
00175 { char *atp;
00176   struct tm tms1, *tms;
00177   pointer a=argv[0];
00178   int i;
00179 #define ASCTIME_STRLEN  30      /* at lease 26 chars */
00180   char at[ASCTIME_STRLEN];
00181 
00182   ckarg(1);
00183   if (isintvector(argv[0])) tms=(struct tm *)a->c.ivec.iv;
00184   else if (isvector(a)) {
00185     tms1.tm_sec=ckintval(a->c.vec.v[0]);
00186     tms1.tm_min=ckintval(a->c.vec.v[1]);
00187     tms1.tm_hour=ckintval(a->c.vec.v[2]);
00188     tms1.tm_mday=ckintval(a->c.vec.v[3]);
00189     tms1.tm_mon=ckintval(a->c.vec.v[4]);
00190     tms1.tm_year=ckintval(a->c.vec.v[5]);
00191     tms1.tm_wday=ckintval(a->c.vec.v[6]);
00192     /* tms1.tm_yday=ckintval(a->c.vec.v[7]); */
00193     tms1.tm_isdst=(a->c.vec.v[8]==NIL)?0:1;
00194     tms= &tms1; }
00195   else error(E_NOINTVECTOR);
00196 #if defined(__USE_POSIX) || Cygwin || Linux
00197   atp=asctime_r(tms,at);        /* asctime --> asctime_r */
00198 #else
00199   atp=asctime_r(tms,at,ASCTIME_STRLEN); /* asctime --> asctime_r */
00200 #endif
00201   return(makestring(atp,strlen(atp)));}
00202 
00203 #if !Solaris2
00204 #include <sys/resource.h>
00205 pointer GETRUSAGE(ctx,n,argv)
00206 register context *ctx;
00207 int n; pointer argv[];
00208 { register int who,i;
00209   long rusage[18];
00210   eusfloat_t utime,stime;
00211   register pointer r=NIL;
00212   numunion nu;
00213 
00214   ckarg(1); who=ckintval(argv[0]);
00215   getrusage(who,(struct rusage *)rusage);
00216   utime=rusage[0]+rusage[1]*1.0e-6;
00217   stime=rusage[2]+rusage[3]*1.0e-6;
00218   for (i=17; i>=4; i--) r=cons(ctx,makeint(rusage[i]),r);
00219   r=cons(ctx,makeflt(stime),r); r=cons(ctx,makeflt(utime),r);
00220   /*(utime stime maxrss ixrss idrss isrss page-reclaims page-faults swap
00221         inblock outblock msgsnd msgrcv nsignals
00222         voluntary-context-switch involuntary-context-switch) */
00223   return(r);}
00224 
00225 pointer GETPAGESIZE(ctx,n,argv)
00226 register context *ctx;
00227 int n; pointer argv[];
00228 { ckarg(0);
00229   return(makeint(getpagesize())); }
00230 
00231 #endif
00232 
00233 pointer GETTIMEOFDAY(ctx,n,argv)
00234 register context *ctx;
00235 int n;
00236 register pointer argv[];
00237 { struct timeval /*{long tv_sec, tv_usec;}*/ tm;
00238   eusfloat_t ftime;
00239   pointer p;
00240 
00241   /* (sec usec timezone daylight) */
00242   /* timezone is seconds west to the GMT */
00243   gettimeofday(&tm, 0);
00244   p=cons(ctx, makeint(daylight), NIL);
00245   p=cons(ctx, makeint(timezone),p);
00246   p=cons(ctx, makeint(tm.tv_usec), p);
00247   vpush(p);
00248   p=cons(ctx, mkbigint(tm.tv_sec), p);
00249   vpop();
00250   return(p);}
00251 
00252 pointer GETITIMER(ctx,n,argv)
00253 register context *ctx;
00254 int n;
00255 register pointer argv[];
00256 { int stat;
00257   struct itimerval tmval;
00258   eusfloat_t interval,value;
00259   numunion nu;
00260   ckarg(1);
00261   stat=getitimer(ckintval(argv[0]), &tmval);
00262   if (stat<0) return(NIL);
00263   interval=tmval.it_interval.tv_sec + ( tmval.it_interval.tv_usec*1.0E-6);
00264   value=tmval.it_value.tv_sec + (tmval.it_value.tv_usec*1.0E-6);
00265   return(cons(ctx,makeflt(value),
00266          cons(ctx,makeflt(interval),NIL)));}
00267 
00268 pointer SETITIMER(ctx,n,argv)
00269 register context *ctx;
00270 int n;
00271 register pointer argv[];
00272 { int stat;
00273   pointer result=NIL;
00274   struct itimerval tmval,oldtmval;
00275   eusfloat_t interval,value;
00276   numunion nu;
00277 
00278   ckarg(3);
00279   value=ckfltval(argv[1]); interval=ckfltval(argv[2]);
00280   tmval.it_value.tv_sec=value;
00281   tmval.it_value.tv_usec=(value-tmval.it_value.tv_sec)*1.0E6;
00282   tmval.it_interval.tv_sec=interval;
00283   tmval.it_interval.tv_usec=(interval-tmval.it_interval.tv_sec)*1.0E6;
00284   stat=setitimer(ckintval(argv[0]), &tmval, &oldtmval);
00285   if (stat<0) return(result);
00286   interval=oldtmval.it_interval.tv_sec + (oldtmval.it_interval.tv_usec*1.0E-6);
00287   value=oldtmval.it_value.tv_sec + (oldtmval.it_value.tv_usec*1.0E-6);
00288   return(cons(ctx,makeflt(interval),
00289          cons(ctx,makeflt(value),result)));}
00290 #endif /* ! vxworks */
00291 
00292 /****************************************************************/
00293 /* signal handling
00294 /****************************************************************/
00295 
00296 #ifdef SIGADDSET
00297 #undef SIGADDSET
00298 #endif
00299 #ifdef SIGDELSET
00300 #undef SIGDELSET
00301 #endif
00302 
00303 pointer SIGADDSET(ctx,n,argv)
00304 register context *ctx;
00305 int n;
00306 register pointer argv[];
00307 { int signum;
00308   sigset_t *set;
00309   ckarg(2);
00310   signum=ckintval(argv[1]);
00311   if (isvector(argv[0]) &&
00312         ((elmtypeof(argv[0])==ELM_INT) || (elmtypeof(argv[0])==ELM_BIT))) {
00313     set=(sigset_t *)argv[0]->c.ivec.iv;
00314     sigaddset(set, signum);
00315     return(argv[0]);}
00316   else error(E_USER,(pointer)"integer/bit vector expected for sigaddset");
00317   }
00318 
00319 pointer SIGDELSET(ctx,n,argv)
00320 register context *ctx;
00321 int n;
00322 register pointer argv[];
00323 { int signum;
00324   sigset_t *set;
00325   ckarg(2);
00326   signum=ckintval(argv[1]);
00327   if (isvector(argv[0]) &&
00328         ((elmtypeof(argv[0])==ELM_INT) || (elmtypeof(argv[0])==ELM_BIT))) {
00329     set=(sigset_t *)argv[0]->c.ivec.iv;
00330     sigdelset(set, signum);
00331     return(argv[0]);}
00332   else error(E_USER,(pointer)"integer/bit vector expected for sigaddset");
00333   }
00334 
00335 pointer SIGPROCMASK(ctx,n,argv)
00336 context *ctx;
00337 int n;
00338 pointer argv[];
00339 { sigset_t *set, *oset;
00340   int how, stat;
00341   ckarg2(2,3);
00342   how=ckintval(argv[0]);
00343   if (isvector(argv[1]) &&
00344         ((elmtypeof(argv[1])==ELM_INT) || (elmtypeof(argv[1])==ELM_BIT))) {
00345     set=(sigset_t *)argv[1]->c.ivec.iv;
00346     if (isvector(argv[2]) &&
00347         ((elmtypeof(argv[2])==ELM_INT) || (elmtypeof(argv[2])==ELM_BIT))) 
00348       oset=(sigset_t *)argv[2]->c.ivec.iv;
00349     else oset=(sigset_t *)0;
00350     stat=sigprocmask(how, set, oset);
00351     if (stat==0) return(T); else return(makeint(-errno));
00352     }
00353   else error(E_USER,(pointer)"integer/bit vector expected for sigprocmask");
00354   }
00355 
00356 pointer KILL(ctx,n,argv)
00357 register context *ctx;
00358 int n;
00359 register pointer argv[];
00360 { ckarg(2);
00361   return(makeint(kill(ckintval(argv[0]),ckintval(argv[1]))));}
00362 
00363 #if Solaris2 || Linux || IRIX || IRIX6 || Cygwin
00364 pointer SIGNAL(ctx,n,argv)
00365 register context *ctx;
00366 int n;
00367 pointer argv[];
00368 { register int s,i;eusinteger_t f;
00369   struct sigaction sv;
00370   register pointer a=argv[1],oldval;
00371   extern void eusint(); 
00372 
00373   ckarg2(1,3);
00374   s=min(ckintval(argv[0]),NSIG-1);
00375   oldval=eussigvec[s];
00376   if (n==1) return(oldval);
00377   if (isint(a)) { f=max(1,intval(a)); eussigvec[s]=NIL;}
00378   else { f=(eusinteger_t)eusint; eussigvec[s]=a;}
00379   sv.sa_handler= (void (*)())f;
00380 #if Linux || Cygwin
00381 
00382 #if LIB6 && !Darwin
00383   for (i=0; i< _SIGSET_NWORDS; i++)   sv.sa_mask.__val[i]=0; 
00384 #else
00385   /* old type sigmask */
00386   sv.sa_mask=0;
00387 #endif 
00388 /*LIB6*/
00389 
00390 #elif (IRIX || IRIX6) && !IRIX6_2
00391   for (i=0; i<4; i++)   sv.sa_mask.sigbits[i]=0;
00392 #else
00393   for (i=0; i<4; i++)   sv.sa_mask.__sigbits[i]=0;
00394 #endif
00395 
00396   if (n==3) sv.sa_flags= ckintval(argv[2]);
00397   else sv.sa_flags=0;
00398   /* printf("signal %d flag=%d\n", s, sv.sa_flags); */
00399   s=sigaction(s,&sv,0);
00400   if (s== -1) return(makeint(-errno)); else return(oldval);
00401   }
00402 
00403 #else
00404 pointer SIGNAL(ctx,n,argv)
00405 register context *ctx;
00406 int n;
00407 pointer argv[];
00408 { register int s;eusinteger_t f;
00409   struct sigvec sv;
00410   register pointer a=argv[1],oldval;
00411   extern void eusint();
00412 
00413   ckarg2(1,3);
00414   s=min(ckintval(argv[0]),NSIG-1);
00415   oldval=eussigvec[s];
00416   if (n==1) return(oldval);
00417   if (isint(a)) { f=max(1,intval(a)); eussigvec[s]=NIL;}
00418   else { f=(eusinteger_t)eusint; eussigvec[s]=a;}/* ???? */
00419   sv.sv_handler=(void (*)())f;
00420   sv.sv_mask=0; /*sigmask(s)???;*/
00421 /*news doesn't have system5 compatible signal handling option*/
00422 #if sun3 || sun4  || mips || alpha
00423   if (n==3) sv.sv_flags=ckintval(argv[2]);
00424   else sv.sv_flags=0;
00425 #endif
00426   s=sigvec(s,&sv,0);
00427   if (s== -1) return(makeint(-errno)); else return(oldval);
00428   }
00429 
00430 #endif
00431 
00432 #if !vxworks
00433 
00434 #include <sys/wait.h>
00435 pointer WAIT(ctx,n,argv)
00436 register context *ctx;
00437 int n;
00438 pointer argv[];
00439 { int completion=0, stat;
00440   GC_REGION(stat = wait(&completion););
00441   return(cons(ctx,makeint(stat),
00442          cons(ctx,makeint(completion),NIL)));}
00443 
00444 pointer ALARM(ctx,n,argv)
00445 register context *ctx;
00446 int n; pointer argv[];
00447 { ckarg(1);
00448   return(makeint(alarm(ckintval(argv[0]))));}
00449 
00450 
00451 #if sun3 || sun4 || news || sanyo  || alpha || i386 || x86_64 || ARM
00452 #if !Solaris2
00453 pointer UALARM(ctx,n,argv)
00454 register context *ctx;
00455 int n; pointer argv[];
00456 { ckarg(2);
00457   return(makeint(ualarm(ckintval(argv[0]), ckintval(argv[1]))));}
00458 #endif
00459 #endif
00460 
00461 #endif 
00462 
00463 /**********************************************/
00464 /* process, user, and group identification 
00465 /**********************************************/
00466 
00467 pointer GETPID(ctx,n,argv)
00468 register context *ctx;
00469 int n;
00470 pointer *argv;  /* unused argument */
00471 { ckarg(0);
00472   return(makeint(getpid()));}
00473 
00474 #if !vxworks
00475 pointer GETPPID(ctx,n,argv)
00476 register context *ctx;
00477 int n;
00478 pointer argv[];
00479 { ckarg(0);
00480   return(makeint(getppid()));}
00481 
00482 pointer GETPGRP(ctx,n,argv)
00483 register context *ctx;
00484 int n;
00485 pointer argv[];
00486 #if system5 | Linux | Cygwin
00487 { ckarg(0);
00488   return(makeint(getpgrp()));}
00489 #else
00490 { int pid;
00491   if (n==1) pid=ckintval(argv[0]);
00492   else pid=getpid();
00493   return(makeint(getpgrp(pid)));}
00494 #endif
00495 
00496 pointer SETPGRP(context *ctx, int n, pointer *argv)
00497 #if system5 | Linux | Cygwin
00498 { ckarg(0);
00499   return(makeint(setpgrp()));}
00500 #else
00501 { int pid;
00502   ckarg(2);
00503   return(makeint(setpgrp(ckintval(argv[0]),ckintval(argv[1]))));}
00504 #endif
00505 
00506 pointer GETUID(context *ctx, int n, pointer *argv)
00507 { ckarg(0);
00508   return(makeint(getuid()));}
00509 
00510 pointer GETEUID(ctx,n,argv)
00511 register context *ctx;
00512 int n;
00513 pointer argv[];
00514 { ckarg(0);
00515   return(makeint(geteuid()));}
00516 
00517 pointer GETGID(ctx,n,argv)
00518 register context *ctx;
00519 int n;
00520 pointer argv[];
00521 { ckarg(0);
00522   return(makeint(getgid()));}
00523 
00524 pointer GETEGID(ctx,n,argv)
00525 register context *ctx;
00526 int n;
00527 pointer argv[];
00528 { ckarg(0);
00529   return(makeint(getegid()));}
00530 
00531 pointer SETUID(ctx,n,argv)
00532 register context *ctx;
00533 int n;
00534 pointer argv[];
00535 { ckarg(1);
00536   n=setuid(ckintval(argv[0]));
00537   if (n<0) return(makeint(errno)); else return(T);}
00538 
00539 pointer SETGID(ctx,n,argv)
00540 register context *ctx;
00541 int n;
00542 pointer argv[];
00543 { ckarg(1);
00544   n=setgid(ckintval(argv[0]));
00545   if (n<0) return(makeint(errno)); else return(T);}
00546 
00547 #endif 
00549 #if system5 || Linux || Cygwin
00550 pointer UNAME(ctx,n,argv)
00551 register context *ctx;
00552 int n;
00553 pointer *argv;
00554 { struct utsname u;
00555   pointer s;
00556   ckarg(0);
00557   uname(&u);
00558   vpush(makestring(u.sysname,strlen(u.sysname)));
00559   vpush(makestring(u.nodename,strlen(u.nodename)));
00560   vpush(makestring(u.release,strlen(u.release)));
00561   vpush(makestring(u.version,strlen(u.version)));
00562   vpush(makestring(u.machine,strlen(u.machine)));
00563   s=stacknlist(ctx,5);
00564   return(s);}
00565 #endif
00566 
00567 /****************************************************************/
00568 /* process creation and deletion 
00569 /****************************************************************/
00570 #if !vxworks
00571 #if !Solaris2 || !THREADED
00572 pointer FORK(ctx,n,argv)
00573 register context *ctx;
00574 int n;
00575 pointer *argv;
00576 { ckarg(0);
00577   return(makeint(fork()));
00578   }
00579 #else
00580 /*  for the problem of calling fork(2) in MT   *
00581  *  Jan. 10 2003 by ikuo@jsk.t.u-tokyo.ac.jp   */
00582 static int ctxid_in_child;
00583 static void *prepare(void) {
00584   int i, me=thr_self();
00585   /* preserve current context */
00586   ctxid_in_child=me;
00587   /* suspend all threads except self */
00588   for (i=0; i<MAXTHREAD; i++) {
00589     if (euscontexts[i]!=0 && i!=me &&
00590         euscontexts[i]->threadobj->c.thrp.suspend==NIL) {
00591       thr_suspend(i);
00592       euscontexts[i]->threadobj->c.thrp.suspend=T; } }
00593 }
00594 static void *parent(void) {
00595   /* continue all suspended threads */
00596   int i, me=thr_self();
00597   for (i=0; i<MAXTHREAD; i++) {
00598     if (euscontexts[i]!=0 && i!=me) {
00599       euscontexts[i]->threadobj->c.thrp.suspend=NIL;
00600       thr_continue(i); } }
00601 }
00602 static void *child(void) {
00603   /* do not continue suspended threads */
00604   int me=thr_self();
00605   /* copy current context (tid changed in child) */
00606   euscontexts[me] = euscontexts[ctxid_in_child];
00607 }
00608 pointer FORK(register context *ctx, int n, pointer *argv)
00609 {ckarg(0);
00610  pthread_atfork (prepare, parent, child);
00611  return(makeint(fork()));
00612 }
00613 #endif /* endof Solaris || THREADED */
00614 
00615 #if Solaris2
00616 pointer FORK1(ctx,n,argv)
00617 register context *ctx;
00618 int n;
00619 pointer *argv;
00620 { ckarg(0);
00621   return(makeint(fork1()));
00622   }
00623 #endif
00624 
00625 #if sun3 || sun4 || vax || news || sanyo || (mips && !IRIX && !IRIX6) || i386 || alpha || x86_64 || ARM
00626 pointer VFORK(ctx,n,argv)
00627 register context *ctx;
00628 int n;
00629 pointer *argv;
00630 { ckarg(0);
00631   return(makeint(vfork()));} 
00632 #endif
00633 
00634 pointer EXEC(ctx,n,argv)
00635 register context *ctx;
00636 int n;
00637 pointer *argv;
00638 { byte *exeargv[512];
00639   int i=0,stat;
00640   if (n>512) error(E_MISMATCHARG);
00641   while (i<n) {
00642     exeargv[i]=Getstring(argv[i])->c.str.chars;
00643     i++;}
00644   exeargv[i]=0;
00645   stat=execvp(exeargv[0],(char **)exeargv);
00646   return(makeint(-errno));}       
00647 
00648 #if !Solaris2
00649 static pointer SETPRIORITY(ctx,n,argv)
00650 register context *ctx;
00651 int n;
00652 pointer *argv;
00653 /* (SETPRIORITY which who priority)
00654         which 0:process,  1:process-group,  2:user
00655         who   0:self, others pid, pgrp-id user-id */ 
00656 { ckarg(3);
00657   return(makeint(setpriority(ckintval(argv[0]),
00658                              ckintval(argv[1]),
00659                              ckintval(argv[2]))));}
00660 
00661 static pointer GETPRIORITY(ctx,n,argv)
00662 register context *ctx;
00663 int n;
00664 pointer *argv;
00665 /* (GETPRIORITY which who) */
00666 { ckarg(2);
00667   return(makeint(getpriority(ckintval(argv[0]), ckintval(argv[1]))));}
00668 #endif  
00669 #endif  
00671 pointer EXIT(ctx,n,argv)
00672 register context *ctx;
00673 int n;
00674 pointer *argv;
00675 { pointer exithook=speval(QEXITHOOK);
00676 /*
00677   Exit function can not finish threads which create in Euslisp 
00678 on SunOS 4.1. So we use thr_exit function on SunOS 4.1.
00679 */
00680 #if SunOS4_1 /* changed by H.Nakagaki at 28-Jun-1995 */
00681   if (n==0) thr_exit(0);
00682   else thr_exit(ckintval(argv[0]));
00683 #else
00684     if (exithook != NIL) {
00685       ufuncall(ctx,exithook,exithook,(pointer)(ctx->vsp-n),0,n);}
00686   if (n==0) exit(0);
00687   else exit(ckintval(argv[0]));
00688 #endif
00689 }
00690 
00691 pointer _EXIT(ctx,n,argv)
00692 register context *ctx;
00693 int n;
00694 pointer *argv;
00695 { pointer exithook=speval(QEXITHOOK);
00696   if (n==0) _exit(0);
00697   else _exit(ckintval(argv[0]));
00698 }
00699 
00700 /****************************************************************/
00701 /* unix raw I/O and file systems
00702 /****************************************************************/
00703 
00704 pointer UNIXREAD(ctx,n,argv)
00705 register context *ctx;
00706 int n;
00707 pointer argv[];
00708 /* (unix:read stream [length]) */
00709 /* (unix:read fd buffer [length [offset]]) */
00710 #if (WORD_SIZE == 64)
00711 { register int fd,offset=0;
00712   register long int size;
00713 #else
00714 { register int fd,size,offset=0;
00715 #endif
00716   register pointer strm,buf,count;
00717   byte *bufp;
00718   
00719   ckarg2(1,4);
00720   strm=argv[0];
00721   if (isiostream(strm)) strm=strm->c.iostream.in;
00722   if (isfilestream(strm)) {
00723     if (strm->c.stream.direction!=K_IN) error(E_IODIRECTION);
00724     if (isint(strm->c.fstream.fname)) error(E_STREAM);
00725     buf=strm->c.fstream.buffer;
00726     bufp=buf->c.str.chars;
00727     fd=intval(strm->c.fstream.fd);
00728     if (n==2) size=min(strlength(buf),ckintval(argv[1]));
00729     else size=strlength(buf);}
00730   else if (isint(strm)) {
00731     fd=intval(strm);
00732     buf=argv[1];
00733     if (isvector(buf) && (elmtypeof(buf)==ELM_FOREIGN)) 
00734       bufp=buf->c.foreign.chars;
00735     else if (isstring(buf)) bufp=buf->c.str.chars;
00736     else error(E_NOSTRING);
00737     if (n>=3) size=min(strlength(buf),ckintval(argv[2]));
00738     else size=strlength(buf);
00739     if (n==4) offset=ckintval(argv[3]);}
00740   else error(E_STREAM);
00741   GC_REGION(size=read(fd, &bufp[offset],size););
00742   count=makeint(size);
00743   if (isstream(strm)) {
00744     strm->c.stream.count=0; strm->c.stream.tail=count;}
00745   if (size<0) return(makeint(-errno));
00746   else return(count);}
00747 
00748 pointer UNIXWRITE(ctx,n,argv)
00749 register context *ctx;
00750 register int n;
00751 pointer *argv;
00752 /* (unix:write fd string [count]) 
00753    (unix:write stream string [count]) */
00754 { register pointer strm,buf;
00755   register int size,fd;
00756   byte *bufp;
00757   ckarg2(2,3);
00758   strm=argv[0];
00759   if (isiostream(strm)) strm=strm->c.iostream.out;
00760   if (isfilestream(strm)) {
00761     if (strm->c.stream.direction!=K_OUT) error(E_IODIRECTION);
00762     if (isint(strm->c.fstream.fname)) error(E_STREAM);
00763     fd=intval(strm->c.fstream.fd);}
00764   else if (isint(strm)) fd=intval(strm);
00765   else error(E_STREAM);
00766   buf=argv[1];
00767   if (isvector(buf) && (elmtypeof(buf)==ELM_FOREIGN)) 
00768     bufp=buf->c.foreign.chars;
00769   else if (isstring(buf)) bufp=buf->c.str.chars;
00770   else error(E_NOSTRING);
00771   size=strlength(buf);
00772   if (n==3) size=min(size,ckintval(argv[2])); 
00773   size=write(fd,bufp,size);
00774   return(makeint(size));}
00775 
00776 
00777 pointer UNIXCLOSE(ctx,n,argv)
00778 register context *ctx;
00779 int n;
00780 pointer argv[];
00781 { ckarg(1);
00782   if (close(ckintval(argv[0]))==0) return(T); else return(makeint(errno));}
00783 
00784 
00785 #if !Cygwin /* Cygwin does not have lockf */
00786 pointer LOCKF(ctx,n,argv)
00787 register context *ctx;
00788 int n;
00789 pointer argv[];
00790 { register pointer a=argv[0];
00791   int fd,func,size,result;
00792   ckarg2(2,3);
00793   if (isiostream(a)) a=a->c.iostream.out;
00794   if (isfilestream(a)) fd=intval(a->c.fstream.fd);
00795   else if (isint(argv[0])) fd=intval(argv[0]);
00796   else error(E_STREAM);
00797   func= ckintval(argv[1]);
00798   if (n==3) size=ckintval(argv[2]);
00799   else size=0;
00800   result=lockf(fd,func,size);
00801   return(makeint(result));}
00802 #endif
00803 
00804 #include <fcntl.h>
00805 pointer FCNTL(ctx,n,argv)
00806 register context *ctx;
00807 int n;
00808 pointer argv[];
00809 { register pointer a=argv[0]; int fd,result;
00810   ckarg(3);
00811   if (isiostream(a)) a=a->c.iostream.in;
00812   if (isfilestream(a)) fd=intval(a->c.fstream.fd);
00813   else if (isint(argv[0])) fd=intval(argv[0]);
00814   else error(E_STREAM);
00815   result=fcntl(fd,ckintval(argv[1]),ckintval(argv[2]));
00816   return(makeint(result));}
00817 
00818 
00819 pointer IOCTL(ctx,n,argv)
00820 register context *ctx;
00821 int n;
00822 register pointer argv[];
00823 { register pointer strm;
00824   eusinteger_t ctlarg;
00825   int request;
00826   int fd;
00827   ckarg(3);
00828   strm=argv[0];
00829   if (isiostream(strm)) strm=strm->c.iostream.out;
00830   if (isfilestream(strm)) {
00831     fd=intval(strm->c.fstream.fd);
00832     if (isint(strm->c.fstream.fname)) error(E_STREAM);}
00833   else fd=ckintval(argv[0]);
00834   if (isint(argv[1]))  request=ckintval(argv[1]);
00835   else if (isflt(argv[1])) error(E_NOINT);
00836   else request=argv[1]->c.ivec.iv[0];
00837   if (isstring(argv[2])) ctlarg=(eusinteger_t)(argv[2]->c.str.chars);/* ???? */
00838   else ctlarg=ckintval(argv[2]);
00839   return(makeint(ioctl(fd,request,ctlarg)));
00840   }
00841 
00842 
00843 #if !vxworks && !Solaris2
00844 int bytesize(p)
00845 pointer p;
00846 { register int s=vecsize(p);
00847   switch (elmtypeof(p)) {
00848     case ELM_BIT: return((s+7)/8);
00849     case ELM_BYTE: case ELM_CHAR: case ELM_FOREIGN: return(s);
00850     case ELM_FLOAT: return(s*sizeof(float));
00851     case ELM_INT: return(s*sizeof(int));
00852     default: return(s*sizeof(pointer));}}
00853 
00854 #if Linux_ppc
00855 #define IOC_IN   _IOC_READ
00856 #define IOC_OUT  _IOC_WRITE
00857 #define IOC_INOUT  (IOC_IN | IOC_OUT)
00858 #endif
00859 
00860 
00861 pointer IOCTL_(ctx,n,argv)
00862 register context *ctx;
00863 /* (UNIX:IOCTL_ stream command1 command2) */
00864 /* equivalent to C's ioctl(dev, _IO(command1, command2), addr) */
00865 int n;
00866 register pointer argv[];
00867 { register pointer strm;
00868   int size=0,x,y,fd;
00869   eusinteger_t addr;
00870   ckarg(3);
00871   strm=argv[0];
00872   if (isiostream(strm)) strm=strm->c.iostream.out;
00873   if (isfilestream(strm)) fd=intval(strm->c.fstream.fd);
00874   else fd=ckintval(strm);
00875   if (isint(strm->c.fstream.fname)) error(E_STREAM);
00876   x=ckintval(argv[1]); y=ckintval(argv[2]);
00877 #if alpha || Linux_ppc
00878   if (ioctl(fd,_IO(x, y), addr))
00879 #else
00880   if (ioctl(fd,IOC_VOID | (size<<16) | (x<<8) | y, addr))
00881 #endif
00882      return(makeint(-errno));
00883   else return(T);  }
00884 
00885 pointer IOCTL_R(ctx,n,argv)
00886 register context *ctx;
00887 /* (UNIX:IOCTL_R stream x y buffer [size]) */
00888 /* equivalent to C's ioctl(dev, _IORN(size, x, y), addr) */
00889 int n;
00890 register pointer argv[];
00891 { register pointer strm;
00892   int size,x,y,fd;
00893   eusinteger_t addr;
00894   ckarg2(4,5);
00895   strm=argv[0];
00896   if (isiostream(strm)) strm=strm->c.iostream.out;
00897   if (isfilestream(strm)) fd=intval(strm->c.fstream.fd);
00898   else fd=ckintval(strm);
00899   if (isint(strm->c.fstream.fname)) error(E_STREAM);
00900   x=ckintval(argv[1]); y=ckintval(argv[2]);
00901   if (isstring(argv[3]) || isintvector(argv[3]))
00902         addr=(eusinteger_t)(argv[3]->c.str.chars);/* ???? */
00903   else error(E_NOSTRING);
00904   if (n==5) size=ckintval(argv[4]);
00905   else size=bytesize(argv[3]);
00906 #if alpha
00907   if (ioctl(fd,_IOC(IOC_OUT, x, y, size), addr))
00908 #else
00909   if (ioctl(fd,IOC_OUT | (size<<16) | (x<<8) | y, addr))
00910 #endif
00911     return(makeint(-errno));
00912   else return(T);  }
00913 
00914 pointer IOCTL_W(ctx,n,argv)
00915 register context *ctx;
00916 /* (UNIX:IOCTL_W stream x y buffer [size]) */
00917 /* equivalent to C's ioctl(dev, _IOWN(size, x, y), addr) */
00918 int n;
00919 register pointer argv[];
00920 { register pointer strm;
00921   int size,x,y,fd;
00922   eusinteger_t addr;
00923   ckarg2(4,5);
00924   strm=argv[0];
00925   if (isiostream(strm)) strm=strm->c.iostream.out;
00926   if (isfilestream(strm)) fd=intval(strm->c.fstream.fd);
00927   else fd=ckintval(strm);
00928   if (isint(strm->c.fstream.fname)) error(E_STREAM);
00929   x=ckintval(argv[1]); y=ckintval(argv[2]);
00930   if (isstring(argv[3]) || isintvector(argv[3]))
00931         addr=(eusinteger_t)(argv[3]->c.str.chars);/* ???? */
00932   else error(E_NOSTRING);
00933   if (n==5) size=ckintval(argv[4]);
00934   else size=bytesize(argv[3]);
00935 #if alpha || Linux_ppc
00936   if (ioctl(fd,_IOC(IOC_IN, x, y, size), addr))
00937 #else
00938   if (ioctl(fd,IOC_IN | (size<<16) | (x<<8) | y, addr))
00939 #endif
00940     return(makeint(-errno));
00941   else return(T);  }
00942 
00943 #if !Cygwin /* Cygwin does not have IOC_INOUT */
00944 pointer IOCTL_WR(ctx,n,argv)
00945 register context *ctx;
00946 /* (UNIX:IOCTL_WR stream x y buffer [size]) */
00947 /* equivalent to C's ioctl(dev, _IOWRN(size, x, y), addr) */
00948 int n;
00949 register pointer argv[];
00950 { register pointer strm=argv[0];
00951   int size,x,y,fd;
00952   eusinteger_t addr;
00953 
00954   ckarg2(4,5);
00955   if (isiostream(strm)) strm=strm->c.iostream.out;
00956   if (isfilestream(strm)) fd=intval(strm->c.fstream.fd);
00957   else fd=ckintval(strm);
00958   if (isint(strm->c.fstream.fname)) error(E_STREAM);
00959   x=ckintval(argv[1]); y=ckintval(argv[2]);
00960   if (isstring(argv[3]) || isintvector(argv[3]))
00961         addr=(eusinteger_t)(argv[3]->c.str.chars);
00962   else error(E_NOSTRING);
00963   if (n==5) size=ckintval(argv[4]);
00964   else size=bytesize(argv[3]);
00965 #if alpha || Linux_ppc
00966   if (ioctl(fd,_IOC(IOC_INOUT, x, y, size), addr))
00967 #else
00968   if (ioctl(fd,IOC_INOUT | (size <<16) | (x<<8) | y, addr))
00969 #endif
00970     return(makeint(-errno)) ;
00971   else return(T);  }
00972 #endif /*Cygwin*/
00973 
00974 #endif /*vxworks*/
00975 
00976 /* DUP and DUP2 work only for numeric fd, not for stream obj.*/
00977 #if !vxworks
00978 
00979 pointer DUP(ctx,n,argv)
00980 register context *ctx;
00981 int n;
00982 pointer *argv;
00983 { int newfd,oldfd;
00984   ckarg(1);
00985   oldfd=ckintval(argv[0]);
00986   newfd=dup(oldfd);
00987   return(makeint(newfd));}
00988 
00989 pointer DUP2(ctx,n,argv)
00990 register context *ctx;
00991 int n;
00992 pointer *argv;
00993 { int newfd,oldfd,stat;
00994   ckarg(2);
00995   newfd=ckintval(argv[0]);
00996   oldfd=ckintval(argv[1]);
00997   stat=dup2(newfd,oldfd);
00998   return(makeint(stat));}
00999 
01000 pointer MKNOD(ctx,n,argv)
01001 register context *ctx;
01002 int n;
01003 pointer *argv;
01004 { int stat;
01005   ckarg(2);
01006   stat=mknod((char *)Getstring(argv[0])->c.str.chars,ckintval(argv[1]),0);
01007   if (stat<0) return(makeint(-errno));
01008   else return(T);}
01009 
01010 pointer MKDIR(ctx, n, argv)
01011 register context *ctx;
01012 int n;
01013 pointer *argv;
01014 { int stat, mode;
01015   ckarg2(1,2);
01016   if (n==2) mode=ckintval(argv[1]); else mode=0775;
01017   stat=mkdir((char *)Getstring(argv[0])->c.str.chars,mode);
01018   if (stat<0) return(makeint(-errno));
01019   else return(T);}
01020 
01021 pointer LINK(ctx,n,argv)
01022 register context *ctx;
01023 int n;
01024 pointer argv[];
01025 { int stat;
01026   ckarg(2);
01027   stat=link(Getstring(argv[0])->c.str.chars,Getstring(argv[1])->c.str.chars);
01028   if (stat<0) return(makeint(-errno)); else return(T);}
01029 
01030 pointer UNLINK(ctx,n,argv)
01031 register context *ctx;
01032 int n;
01033 pointer argv[];
01034 { pointer s;
01035   int stat;
01036   ckarg(1);
01037   s=Getstring(argv[0]);
01038   stat=unlink(s->c.str.chars);
01039   if (stat<0) return(makeint(-errno));
01040   else return(T);}
01041 
01042 pointer RMDIR(ctx,n,argv)
01043 register context *ctx;
01044 int n;
01045 pointer argv[];
01046 { pointer s;
01047   int stat;
01048   ckarg(1);
01049   s=Getstring(argv[0]);
01050   stat=rmdir(s->c.str.chars);
01051   if (stat<0) return(makeint(-errno));
01052   else return(T);}
01053 
01054 pointer RENAME(ctx,n,argv)      /*(rename from to)*/
01055 register context *ctx;
01056 int n;
01057 register pointer argv[];
01058 { byte *from, *to;
01059   int stat;
01060   ckarg(2);
01061   from =(byte *)get_string(argv[0]);
01062   to =(byte *)get_string(argv[1]);
01063   stat=rename((char *)from,(char *) to);
01064   if (stat<0) return(makeint(-errno));
01065   else return(T);}
01066 
01067 pointer ACCESS(ctx,n,argv)
01068 register context *ctx;
01069 int n;
01070 pointer *argv;
01071 { pointer path;
01072   int mode,stat;
01073   ckarg2(1,2);
01074   path=Getstring(argv[0]);
01075   if (n==2) mode=ckintval(argv[1]); else mode=0;
01076   stat=access(path->c.str.chars,mode);
01077   if (stat==0) return(T); else return(makeint(-errno));}
01078 
01079 /*
01080 pointer FLOCK(ctx,n,argv)
01081 register context *ctx;
01082 int n;
01083 pointer argv[];
01084 { int fd=ckintval(argv[0]), op=ckintval(argv[1]), stat;
01085   ckarg(2);
01086   stat=flock(fd,op);
01087   if (stat==0) return(T); else return(makeint(-errno));}
01088 */
01089 
01090 pointer STAT(ctx,n,argv)
01091 register context *ctx;
01092 int n;
01093 pointer *argv;
01094 { register pointer a;
01095   struct stat s;
01096   ckarg(1);
01097   if (stat((char *)Getstring(argv[0])->c.str.chars, &s)<0) return(makeint(-errno));
01098   a=cons(ctx,mkbigint(s.st_ctime),NIL);
01099   a=cons(ctx,mkbigint(s.st_mtime),a);
01100   a=cons(ctx,mkbigint(s.st_atime),a);
01101   a=cons(ctx,makeint(s.st_size),a);
01102   a=cons(ctx,makeint(s.st_gid),a);
01103   a=cons(ctx,makeint(s.st_uid),a);
01104   a=cons(ctx,makeint(s.st_nlink),a);
01105   a=cons(ctx,makeint(s.st_rdev),a);
01106   a=cons(ctx,makeint(s.st_dev),a);
01107   a=cons(ctx,makeint(s.st_ino),a);
01108   a=cons(ctx,makeint(s.st_mode),a);
01109   return(a);}
01110 #endif /* !vxworks*/
01111 
01112 #if Solaris2 || Linux || alpha || Cygwin
01113 /*
01114   Usage: (unix::directory "directory_name")
01115   Return: a reverse list of file names in "directory_name" dir.
01116 */
01117 
01118 pointer DIRECTORY(ctx, n, argv)
01119 register context *ctx;
01120 int n;
01121 pointer argv[];
01122 { register pointer a;
01123   register char *str;
01124   byte *s;
01125   DIR *dirp;
01126   struct dirent *direntp;
01127   int flag=0;
01128 
01129   ckarg2(0,1);
01130   if (n==1)  s=get_string(argv[0]); else s=(byte *)".";
01131   if ( (dirp = opendir((char *)s)) == NULL ) return (NIL);
01132   while ( (direntp = readdir( dirp )) != NULL ){
01133      str=direntp->d_name; 
01134      if(flag) a=cons(ctx,makestring(str,strlen(str)),a);
01135      else { a=cons(ctx,makestring(str,strlen(str)),NIL); flag++;}
01136    }
01137    closedir(dirp);
01138    return (a);
01139 }
01140 #else
01141 pointer DIRECTORY(ctx, n, argv)
01142 register context *ctx;
01143 int n;
01144 pointer argv[];
01145 {
01146    printf("Not Implemented!");
01147    return (NIL);
01148 }
01149 #endif
01150 
01151 pointer LSEEK(ctx,n,argv)
01152 register context *ctx;
01153 int n;
01154 pointer *argv;
01155 { pointer strm,fd;
01156   int whence, ret;
01157   ckarg2(2,3);
01158   if (n==3) whence=ckintval(argv[2]); else whence=0;
01159   strm=argv[0];
01160   if (isiostream(strm)) strm=strm->c.iostream.out;
01161   if (isfilestream(strm)){
01162      fd=strm->c.fstream.fd;
01163      if (isint(strm->c.fstream.fname)) error(E_STREAM);}
01164   else fd=strm;
01165   if (!isint(fd)) error(E_STREAM);
01166   ret=lseek(intval(fd),ckintval(argv[1]),whence);
01167   if (ret==-1) perror("lseek");
01168   return(makeint(ret));  }
01169 
01170 #if !vxworks
01171 /*change current working directory*/
01172 pointer CHDIR(ctx,n,argv)
01173 register context *ctx;
01174 int n;
01175 pointer argv[];
01176 { register int stat;
01177   ckarg(1);
01178   stat=chdir(Getstring(argv[0])->c.str.chars);
01179   if (stat<0) return(makeint(-errno)); else return(T);}
01180 
01181 /*change file access mode*/
01182 pointer CHMOD(ctx,n,argv)
01183 register context *ctx;
01184 int n;
01185 pointer *argv;
01186 { byte *path;
01187   int mode,stat;
01188   ckarg(2);
01189   path=Getstring(argv[0])->c.str.chars;
01190   mode=ckintval(argv[1]);
01191   stat=chmod((char *)path,mode);
01192   if (stat==0) return(T); else return(makeint(errno));}
01193 
01194 /*change file owner*/
01195 pointer CHOWN(ctx,n,argv)
01196 register context *ctx;
01197 int n;
01198 pointer *argv;
01199 { byte *path;
01200   int owner,newowner,stat;
01201   ckarg(3);
01202   path=Getstring(argv[0])->c.str.chars;
01203   owner=ckintval(argv[1]);
01204   newowner=ckintval(argv[2]);
01205   stat=chown(path,owner,newowner);
01206   if (stat==0) return(T); else return(makeint(errno));}
01207 
01208 /*create two pipes*/
01209 pointer PIPE(ctx,n,argv)
01210 register context *ctx;
01211 int n;
01212 pointer *argv;
01213 { int pfd[2],stat,size;
01214   register pointer instream,outstream;
01215 
01216   ckarg2(0,1);
01217   if (n==1) size=ckintval(argv[0]); else size=128;
01218   stat=pipe(pfd);
01219   if (stat<0) return(makeint(-errno));
01220   instream=mkfilestream(ctx,K_IN,makebuffer(size),pfd[0],NIL); /*no file named*/
01221   vpush(instream);
01222   outstream=mkfilestream(ctx,K_OUT,makebuffer(size),pfd[1],NIL);
01223   return((pointer)mkiostream(ctx,vpop(),outstream));
01224   }
01225 
01226 
01227 /* message queu operations */
01228 #if !news
01229 pointer MSGGET(ctx,n,argv)
01230 register context *ctx;
01231 int n;
01232 pointer argv[];
01233 { register int key,qid,mode;
01234   ckarg2(1,2);
01235   key=ckintval(argv[0]);
01236   if (n==2) mode=ckintval(argv[1]); else mode=0666;
01237   qid=msgget(key,IPC_CREAT | (mode & 0777));
01238   return(makeint(qid));}
01239 
01240 pointer MSGRCV(ctx,n,argv)
01241 register context *ctx;
01242 int n;
01243 pointer *argv;
01244 { register int qid,mtype,flag,stat;
01245   register pointer buf,lsave;
01246   ckarg2(2,4);
01247   qid=ckintval(argv[0]);
01248   buf=argv[1];
01249   if (!isstring(buf)) error(E_NOSTRING);
01250   if (n>=3) mtype=ckintval(argv[2]); else mtype=0;
01251   if (n==4) if (argv[3]==NIL) flag=0; else flag=IPC_NOWAIT;
01252   else flag=0;
01253   lsave=buf->c.str.length;
01254   buf->c.str.length=(pointer)(eusinteger_t)mtype;/* ???? */
01255   rcv_again:
01256   stat=msgrcv(qid,&buf->c.str.length,intval(lsave),mtype,flag);
01257   if (stat<0) { breakck; goto rcv_again;}
01258   mtype=(int)(eusinteger_t)(buf->c.str.length);/* ???? */
01259   buf->c.str.length=lsave;
01260   if (stat<0) return(makeint(-errno));
01261   else return(cons(ctx,makeint(mtype),cons(ctx,makeint(stat),NIL)));}
01262   
01263 pointer MSGSND(ctx,n,argv)
01264 register context *ctx;
01265 int n;
01266 pointer *argv;
01267 { register int qid,msize,mtype,flag,stat;
01268   register pointer buf,lsave;
01269   ckarg2(2,5);
01270   qid=ckintval(argv[0]);
01271   buf=argv[1];
01272   if (!isstring(buf)) error(E_NOSTRING);
01273   lsave=buf->c.str.length;
01274   if (n>=3) {
01275     msize=ckintval(argv[2]);
01276     if (msize>intval(lsave) || msize<0) error(E_ARRAYINDEX);}
01277   else msize=intval(lsave);
01278   if (n>=4) mtype=ckintval(argv[3]); else mtype=mypid;
01279   if (n==5) if (argv[4]==NIL) flag=0; else flag=IPC_NOWAIT;
01280   else flag=0;
01281   buf->c.str.length=(pointer)(eusinteger_t)mtype;
01282   stat=msgsnd(qid,(struct msgbuf *)&buf->c.str.length,msize,flag);
01283   buf->c.str.length=lsave;
01284   if (stat<0) return(makeint(-errno));
01285   else return(makeint(stat));}
01286 
01287 pointer MSGCTL(ctx,n,argv)
01288 register context *ctx;
01289 int n;
01290 pointer argv[];
01291 { int qid,cmnd,stat;
01292   byte *buf;
01293   ckarg2(2,3);
01294   qid=ckintval(argv[0]); cmnd=ckintval(argv[1]);
01295   if (n==3) buf=get_string(argv[2]);
01296   else buf=NULL;
01297   stat=msgctl(qid,cmnd,(struct msqid_ds *)buf);
01298   if (stat==(long int)NULL) return(T); else  return(makeint(-errno));}
01299 #endif
01300 #endif 
01301 
01302 /****************************************************************/
01303 /* UNIX subroutines
01304 /****************************************************************/
01305 
01306 pointer SYSTEM(ctx,n,argv)
01307 register context *ctx;
01308 int n;
01309 register pointer argv[];
01310 { int stat;
01311   eusinteger_t s;
01312 /*  extern int eusint(); */
01313   extern void eusint(); /* ???? */
01314 
01315   s=(eusinteger_t)signal(SIGCHLD,SIG_DFL);/* ???? */
01316   if (n==0) stat=system("csh");
01317   else if (isstring(argv[0])) stat=system((char *)argv[0]->c.str.chars);
01318   else { signal(SIGCHLD,(void (*)())s); error(E_NOSTRING);}
01319   signal(SIGCHLD,(void (*)())s);
01320   return(makeint(stat));}
01321 
01322 pointer GETWD(ctx,n,argv)
01323 register context *ctx;
01324 int n;
01325 pointer argv[];
01326 { char buf[256];
01327   ckarg(0);
01328 #if Solaris2 || Linux || Cygwin
01329   char *r = getcwd(buf,256);
01330 #else
01331   getwd(buf);
01332 #endif
01333   return(makestring(buf,strlen(buf)));}
01334 
01335 pointer GETENV(ctx,n,argv)
01336 register context *ctx;
01337 int n;
01338 pointer *argv;
01339 { register char *envval;
01340   ckarg(1);
01341   envval=(char *)getenv((char *)Getstring(argv[0])->c.str.chars);
01342   if (envval) return(makestring(envval,strlen(envval)));
01343   else return(NIL);}
01344 
01345 #if sun3 || sun4 || vax || mips || i386 || alpha || x86_64 || ARM
01346 pointer PUTENV(ctx,n,argv)
01347 register context *ctx;
01348 int n;
01349 pointer argv[];
01350 { 
01351   char *b;
01352   pointer a=argv[0];
01353   ckarg(1);
01354   if (!isstring(a)) error(E_NOSTRING);
01355   b= (char *)malloc(vecsize(a)+1);
01356   strcpy(b, (char *)a->c.str.chars);
01357   putenv(b);
01358   return(makeint((eusinteger_t)b));}
01359 #endif
01360 
01361 pointer ENVIRON(context *ctx, int n, pointer argv[])
01362 { extern char **environ;
01363   char  *b;
01364   int  count=0;
01365   ckarg(0);
01366   while ((b=environ[count++])) {
01367     vpush(makestring(b, strlen(b)));}
01368   return(stacknlist(ctx, count-1)); }
01369 
01370 pointer SLEEP(ctx,n,argv)
01371 register context *ctx;
01372 int n;
01373 pointer *argv;
01374 { ckarg(1);
01375   struct timespec treq;
01376   GC_REGION(treq.tv_sec=ckintval(argv[0]));;
01377   treq.tv_nsec = 0;
01378   if (nanosleep(&treq, NULL)<0) return(NIL);
01379   return(T);}
01380 
01381 
01382 #if sun3 || sun4 && !Solaris2 || Linux || alpha || Cygwin
01383 pointer USLEEP(ctx,n,argv)
01384 register context *ctx;
01385 int n;
01386 pointer *argv;
01387 { ckarg(1);
01388   struct timespec treq;
01389   GC_REGION(treq.tv_sec  =  ckintval(argv[0])/1000000;
01390             treq.tv_nsec = (ckintval(argv[0])%1000000)*1000);
01391   if (nanosleep(&treq, NULL)<0) return(NIL);
01392   return(T);}
01393 #endif
01394 
01395 pointer ERRNO(ctx,n,argv)
01396 context *ctx;
01397 int n;
01398 pointer argv[];
01399 { 
01400   return(makeint(errno));
01401   }
01402 
01403 pointer PERROR(ctx,n,argv)
01404 context *ctx;
01405 int n;
01406 pointer argv[];
01407 { 
01408   ckarg(1);
01409   char *s=Getstring(argv[0])->c.str.chars;
01410   fprintf(stderr, "%c[3%cm;; ERROR ", 0x1b, 49);
01411   perror(s);
01412   fprintf(stderr, "%c[0m", 0x1b);
01413   return T;
01414   }
01415 
01416 pointer SYSERRLIST(ctx,n,argv)
01417 register context *ctx;
01418 register int n;
01419 pointer argv[];
01420 { int i;
01421   char *errstr;
01422   int  errno_save;
01423   ckarg(1);
01424   n=ckintval(argv[0]);
01425   errno_save=errno;
01426   errstr=strerror(n);
01427   if (errno==errno_save) return(makestring(errstr, strlen(errstr)));
01428   else error(E_ARRAYINDEX);}
01429 
01430 pointer PAUSE(ctx,n,argv)
01431 register context *ctx;
01432 int n;
01433 pointer argv[];
01434 { ckarg(0);
01435   return(makeint(pause()));}
01436 
01437 pointer ISATTY(ctx,n,argv)
01438 register context *ctx;
01439 int n;
01440 pointer argv[];
01441 { pointer a;
01442   int fd;
01443   ckarg(1);
01444   a=argv[0];
01445   if (isiostream(a)) a=a->c.iostream.in;
01446   if (isfilestream(a)) fd=intval(a->c.fstream.fd);
01447   else fd=ckintval(a);
01448   /*
01449 #if Cygwin
01450   if (getenv("EMACS") && (strcmp (getenv("EMACS"), "t")) == 0 ) return(T); 
01451 #endif
01452   */
01453   if (isatty(fd)) return(T); else return(NIL);}
01454 
01455 
01456 /****************************************************************/
01457 /* functions for  I P C (interprocess communication)
01458 /* using sockets
01459 /*      1988-Jan        socket for internet
01460 /*      1988-Feb        select system call
01461 /****************************************************************/
01462 
01463 pointer SOCKET(ctx,n,argv)
01464 register context *ctx;
01465 int n;
01466 pointer argv[];
01467 { int proto,s;
01468   ckarg2(2,3);
01469   if (n==3) proto=ckintval(argv[2]);
01470   else proto=0;
01471   s=socket(ckintval(argv[0]),ckintval(argv[1]),proto);
01472   if (s<0) return(makeint(-errno));
01473   else return(makeint(s)); }
01474 
01475 pointer BIND(ctx,n,argv)        /*bind ipc socket to real path name*/
01476 register context *ctx;
01477 int n;
01478 register pointer argv[];
01479 { int s,l;
01480   pointer sockname;
01481   struct sockaddr *sa;
01482 
01483   ckarg(2);
01484   s=ckintval(argv[0]);  /*socket id*/
01485   if (!isstring(argv[1])) error(E_USER,(pointer)"socket address expected");
01486   sa= (struct sockaddr *)(argv[1]->c.str.chars);
01487   if (sa->sa_family==AF_UNIX) l=strlen(sa->sa_data)+2;
01488   else l=sizeof(struct sockaddr_in);
01489   s=(int)bind(s, sa, l);
01490   if (s) return(makeint(-errno)); else return(makeint(0));}
01491   
01492 pointer CONNECT(ctx,n,argv)
01493 register context *ctx;
01494 int n;
01495 pointer argv[];
01496 { int s,l;
01497   struct sockaddr *sa;
01498   ckarg(2);
01499   s=ckintval(argv[0]);          /*socket id*/
01500   if (!isstring(argv[1])) error(E_USER,(pointer)"socket address expected");
01501   sa= (struct sockaddr *)(argv[1]->c.str.chars);
01502   if (sa->sa_family==AF_UNIX) l=strlen(sa->sa_data)+2;
01503   else l=sizeof(struct sockaddr_in);
01504   s=(int)connect(s, sa, l);
01505   breakck;
01506   if (s) return(makeint(-errno)); else return(makeint(0));
01507 }
01508 
01509 pointer LISTEN(ctx,n,argv)
01510 register context *ctx;
01511 int n;
01512 pointer argv[];
01513 { int backlog,stat;
01514   ckarg2(1,2);
01515   if (n==2) backlog=ckintval(argv[1]);
01516   else backlog=3;
01517   stat=listen(ckintval(argv[0]),backlog);
01518   if (stat<0) return(makeint(-errno)); else return(makeint(0));}
01519 
01520 pointer ACCEPT(ctx,n,argv)
01521 register context *ctx;
01522 int n;
01523 pointer argv[];
01524 { int ns,len,s;
01525   pointer sockname;
01526 #if vxworks || Cygwin || Linux || Solaris2
01527   struct sockaddr sockun;
01528 #else 
01529   struct sockaddr_un sockun;    // ??? why not sockaddr or sockaddr_in ???
01530 #endif
01531 
01532   ckarg(1);
01533   len=sizeof(sockun);
01534   s=ckintval(argv[0]);
01535   ns=accept(s, (struct sockaddr *)&sockun, &len);
01536   if (ns<0) return(makeint(-errno));
01537   sockname=makestring((char *)&sockun,len);
01538   return(cons(ctx,makeint(ns),cons(ctx,sockname,NIL)));}
01539 
01540 /* non-connected (datagram) socket communication */
01541 /* Address must be bound to a socket at the receiver side. */
01542 /* Sender specifies the address when it calls SENDTO. */
01543 pointer SENDTO(ctx,n,argv)
01544 register context *ctx;
01545 int n;
01546 pointer argv[];
01547 /* unix: sendto(sock,msg,len,flags,to,tolen) */
01548 /* eus:  (SENDTO sock addr msg [len [flags]]) */
01549 { int len, sock, flags, stat;
01550   pointer msg, addr;
01551   ckarg2(3,5);
01552   sock=ckintval(argv[0]);
01553   addr=(pointer)Getstring(argv[1]);
01554   msg=(pointer)Getstring(argv[2]);
01555   if (n>=4) len=ckintval(argv[3]); else len=vecsize(msg);
01556   if (n>=5) flags=ckintval(argv[4]); else flags=0;
01557   stat=sendto(sock, (char *)msg->c.str.chars, len, flags,
01558                 (struct sockaddr *)addr->c.str.chars, vecsize(addr));
01559   if (stat<0) stat= -errno;
01560   /* returns the number of bytes actually sent*/
01561   return(makeint(stat));}
01562 
01563 pointer RECVFROM(ctx,n,argv)
01564 register context *ctx;
01565 int n;
01566 pointer argv[];
01567 /* unix: recvfrom(s,buf,len,flags,from,fromlen) */
01568 /* eus:  (RECVFROM sock [msg [from [flags]]])
01569          no address is required since it has already bound to
01570          the socket */
01571 { int len=2000, sock, flags, stat, addrlen;
01572   unsigned char buf[2000], *bufp=buf, *addrp=NULL;
01573   pointer msg, addr;
01574   ckarg2(1,4);
01575   sock=ckintval(argv[0]);
01576   if (n>=2) {
01577     msg=argv[1];
01578     if (isstring(msg))  msg=(pointer)Getstring(argv[1]); /*message buffer*/
01579     else msg=makebuffer(ckintval(argv[1]));
01580     bufp=msg->c.str.chars;
01581     len=vecsize(msg);}
01582   if (n>=3) {
01583     addr=Getstring(argv[2]);
01584     addrlen=vecsize(addr);
01585     addrp=addr->c.str.chars;}
01586   if (n>=4) flags=ckintval(argv[3]); else flags=0;
01587   stat=recvfrom(sock, (char *)bufp, len, flags, (struct sockaddr *)addrp, &addrlen);
01588   if (stat<0) return(makeint(-errno));
01589   /* if the result is negative, it indicates error number,
01590      otherwise, the actual length of the message is returned. */
01591   if (n<2) return(makestring((char *)bufp,stat));
01592   else return(makeint(stat));}
01593 
01594 #if !Solaris2
01595 pointer GETPEERNAME(ctx,n,argv)
01596 register context *ctx;
01597 int n;
01598 pointer argv[];
01599 { char name[128];
01600   int namelen, stat;
01601   ckarg(1);
01602   stat=getpeername(ckintval(argv[0]), (struct sockaddr *)name, &namelen);
01603   if (stat<0) return(makeint(-errno));
01604   else return(makestring(name,namelen));}
01605 #endif 
01607 #if !vxworks 
01608 
01609 eusinteger_t *checkbitvec(pointer a, long *size)
01610 { if (a==NIL) { *size=0; return(0);}
01611   if (!isvector(a)) error(E_NOVECTOR);
01612   switch(elmtypeof(a)) {
01613   case ELM_BIT: *size=vecsize(a); return(a->c.ivec.iv);
01614   case ELM_INT: *size=vecsize(a) * WORD_SIZE; return(a->c.ivec.iv);
01615   case ELM_BYTE: case ELM_CHAR:
01616                 *size=vecsize(a) * 8; return(a->c.ivec.iv);
01617   case ELM_FOREIGN: *size=vecsize(a) * 8; return((eusinteger_t *)a->c.foreign.chars);
01618   default: error(E_USER,(pointer)"bit-vector expected");
01619   }
01620 }
01621 
01622 pointer SELECT(ctx,n,argv)
01623 register context *ctx;
01624 int n;
01625 register pointer argv[];
01626 { register pointer a=argv[0];
01627   long i, maxwidth, width,size0, size1, size2;
01628   fd_set *readfds, *writefds, *exceptfds;
01629   eusfloat_t timeout;
01630   struct timeval to;
01631   numunion nu;
01632 
01633   ckarg(4);
01634   readfds=(fd_set *)checkbitvec(argv[0], &size0);
01635   writefds=(fd_set *)checkbitvec(argv[1], &size1);
01636   exceptfds=(fd_set *)checkbitvec(argv[2], &size2);
01637   maxwidth=min(256, max(max(size0, size1), size2)); 
01638 
01639 /*  printf("SELECT: readfds=%x\n", readfds);
01640   printf("SELECT: writefds=%x\n", writefds);
01641   printf("SELECT: exceptfds=%x\n", exceptfds); */
01642 
01643   /* find the highest numbered fd */
01644   width=0;
01645   for (i=0; i<maxwidth; i++) {
01646     if (readfds && FD_ISSET(i, readfds)) width=i;
01647     if (writefds && FD_ISSET(i, writefds)) width=i;
01648     if (exceptfds && FD_ISSET(i, exceptfds)) width=i;}
01649   width = width + 1;
01650 
01651   timeout=ckfltval(argv[3]);
01652   if (timeout==0.0)
01653   {GC_REGION(i=select(width, readfds, writefds, exceptfds,0););}
01654   else {
01655     to.tv_sec=timeout;
01656     timeout=timeout-to.tv_sec;
01657     timeout=timeout*1000000;
01658     to.tv_usec=timeout;
01659     GC_REGION(i=select(width, readfds, writefds, exceptfds,&to);)}
01660   if (i<0) return(makeint(-errno));
01661   else return(makeint(i)); }
01662 
01663 pointer SELECT_READ(ctx,n,argv)
01664 register context *ctx;
01665 int n;
01666 pointer argv[];
01667 { struct timeval to;
01668   eusfloat_t timeout;
01669   long i, size, width, fds;
01670   fd_set *fdvec;
01671   numunion nu;
01672 
01673   ckarg(2);
01674   if (isint(argv[0])) {
01675     fds=intval(argv[0]);
01676     fdvec=(fd_set *)&fds;
01677     size=30;    }
01678   else fdvec=(fd_set *)checkbitvec(argv[0], &size);
01679   size=min(256,size);
01680   for (i=0; i<size; i++) if (FD_ISSET(i, fdvec)) width=i;
01681   width = width+1;
01682      
01683   timeout=ckfltval(argv[1]);
01684   if (timeout==0.0) {GC_REGION(n=select(width, fdvec, 0, 0, 0););}
01685   else {
01686     to.tv_sec=timeout;
01687     timeout=timeout-to.tv_sec;
01688     timeout=timeout*1000000;
01689     to.tv_usec=timeout;
01690     GC_REGION(n=select(width, fdvec, 0, 0, &to););}
01691   if (n<0) return(makeint(-errno));
01692   if (isint(argv[0])) {
01693     /*fds=fdvec-> __fds_bits[0];*/
01694     /* fds_bits should be __fds_bits on some operating systems */
01695     return(makeint(fds)); }
01696   else return(argv[0]); }
01697 
01698 #endif /* !vxworks */
01699 
01700 
01701 /****************************************************************/
01702 /* physical memory allocator
01703 /*      1988-Jul
01704 /****************************************************************/
01705 pointer SBRK(ctx,n,argv)
01706 register context *ctx;
01707 int n; pointer argv[];
01708  { return(makeint((eusinteger_t)sbrk(ckintval(argv[0]))));}
01709 
01710 pointer MALLOC(ctx,n,argv)
01711 register context *ctx;
01712 int n; pointer argv[];
01713  { return(makeint((eusinteger_t)malloc(ckintval(argv[0]))));}
01714 
01715 pointer FREE(ctx,n,argv)
01716 register context *ctx;
01717 int n; pointer argv[];
01718 { free((void *)bigintval(argv[0]));
01719   return(makeint(1));}
01720 
01721 #if sun3 || sun4 || news || alpha
01722 pointer VALLOC(ctx,n,argv)
01723 register context *ctx;
01724 int n; pointer argv[];
01725 { return(makeint(valloc(ckintval(argv[0]))));}
01726 #endif
01727 
01728 #if sun3 || sun4 || news || alpha || Linux || Cygwin
01729 
01730 pointer MMAP(ctx,n,argv)
01731 register context *ctx;
01732 int n; register pointer argv[];
01733 { int fd;
01734   eusinteger_t offset,result,len;
01735   pointer strm;
01736   ckarg(6);
01737   strm=argv[4];
01738   if (isiostream(strm)) strm=strm->c.iostream.in;
01739   if (isfilestream(strm)) fd=intval(strm->c.fstream.fd);
01740   else fd=ckintval(strm);
01741   len=ckintval(argv[1]);
01742   if (isintvector(argv[5])) 
01743     offset=((argv[5]->c.ivec.iv[0])<<16) + argv[5]->c.ivec.iv[1];
01744   else offset=ckintval(argv[5]);
01745   result=(eusinteger_t)mmap((caddr_t)ckintval(argv[0]), len,
01746                 ckintval(argv[2]), ckintval(argv[3]), fd, offset);
01747   if (result== -1) return(makeint(-errno));
01748   else return((pointer)make_foreign_string(result, len));}
01749 
01750 pointer MUNMAP(ctx,n,argv)
01751 register context *ctx;
01752 int n; pointer argv[];
01753 { return(makeint(munmap((caddr_t)ckintval(argv[0]),ckintval(argv[1]))));}
01754 
01755 /*
01756 pointer VADVISE(ctx,n,argv)
01757 register context *ctx;
01758 int n; pointer argv[];
01759 { n=vadvise(ckintval(argv[0]));
01760   if (n==0) return(T); else return(makeint(errno));}
01761 */
01762 
01763 #endif
01764 
01765 /****************************************************************/
01766 /* network library routines
01767 /****************************************************************/
01768 #if !vxworks
01769 
01770 pointer GETHOSTNAME(ctx,n,argv)
01771 register context *ctx;
01772 int n; pointer argv[];
01773 { char buf[32]; int stat;
01774   stat=gethostname(buf,32);
01775   if (stat==0) return(makestring(buf,strlen(buf)));
01776   else return(makeint(errno));}
01777 
01778 pointer GETHOSTBYNAME(ctx,n,argv)
01779 register context *ctx;
01780 int n;
01781 register pointer *argv;
01782 { register struct hostent *hp;
01783   register pointer s;
01784 
01785   ckarg(1);
01786   hp=gethostbyname((char *)Getstring(argv[0])->c.str.chars);
01787   if (hp==NULL) return(makeint(-errno));
01788   s=cons(ctx,makeint(hp->h_addrtype),NIL);
01789   s=cons(ctx,makestring(hp->h_addr,hp->h_length),s);
01790   return(s);}   /*list of 32bit address and address type*/
01791   
01792 pointer GETHOSTBYADDR(ctx,n,argv)
01793 register context *ctx;
01794 int n;
01795 pointer *argv;
01796 { pointer addr;
01797   struct hostent *host;
01798   ckarg(1);
01799   addr=Getstring(argv[0]);
01800   host=gethostbyaddr((char *)addr->c.str.chars, vecsize(addr), 2);
01801   if (host==NULL) return(makeint(-errno));
01802   else return(makestring(host->h_name, strlen(host->h_name)));}
01803 
01804 #if !Cygwin /* Cygwin does not hvae getnetbyname */ 
01805 pointer GETNETBYNAME(ctx,n,argv)
01806 register context *ctx;
01807 int n;
01808 register pointer *argv;
01809 { struct netent *np;
01810   ckarg(1);
01811   np=getnetbyname((char *)Getstring(argv[0])->c.str.chars);
01812   if (np==NULL) return(makeint(-errno));
01813   return(cons(ctx,makeint(np->n_net),
01814               cons(ctx,makeint(np->n_addrtype),NIL)));}
01815 #endif
01816 
01817 pointer GETPROTOBYNAME(ctx,n,argv)
01818 register context *ctx;
01819 int n;
01820 register pointer *argv;
01821 { struct protoent *pp;
01822   ckarg(1);
01823   pp=getprotobyname((char *)Getstring(argv[0])->c.str.chars);
01824   if (pp==NULL) return(makeint(-errno));
01825   return(makeint(pp->p_proto));}
01826 
01827 pointer GETSERVBYNAME(ctx,n,argv)
01828 register context *ctx;
01829 int n;
01830 register pointer *argv;
01831 { struct servent *sp;
01832   pointer s;
01833   byte *p;
01834   long int port;
01835   
01836   ckarg2(1,2);
01837   if (n==2 && argv[1]!=NIL)  p=Getstring(argv[1])->c.str.chars;
01838   else p=NULL;
01839   sp=getservbyname((char *)Getstring(argv[0])->c.str.chars,(char *)p);
01840   if (sp==NULL) return(makeint(-errno));
01841   s=makestring(sp->s_proto,strlen(sp->s_proto));
01842   vpush(s);
01843   port = ntohs(sp->s_port);
01844   s=cons(ctx,makeint(port),cons(ctx,s,NIL));
01845   vpop();
01846   return(s);}
01847 
01848 /* Append by I.Hara for IPC */
01849 /* htons -- convert values between host and network byte order */
01850 pointer H2NS(ctx,n,argv)
01851 register context *ctx;
01852 int n;
01853 register pointer *argv;
01854 { int hostshort;
01855   unsigned short netshort;
01856   ckarg(1);
01857   hostshort=ckintval(argv[0]);
01858   netshort=htons((short)hostshort);
01859   return(makeint(netshort));}
01860 
01861 pointer N2HS(ctx,n,argv)
01862 register context *ctx;
01863 int n;
01864 register pointer *argv;
01865 { int hostshort;
01866   unsigned short netshort;
01867   ckarg(1);
01868   netshort=ckintval(argv[0]);
01869   hostshort=ntohs((short)netshort);
01870   return(makeint(hostshort));}
01871 
01872 #endif
01873 
01874 
01875 
01876 
01877 #ifdef DBM
01878 /* ndbm --- data base 
01879         1988-May
01880         (c) T.Matsui
01881 */
01882 
01883 #if sun3 || sun4
01884 
01885 #include <ndbm.h>
01886 
01887 pointer DBM_OPEN(ctx,n,argv)
01888 register context *ctx;
01889 int n;
01890 register pointer argv[];
01891 { DBM *dbm;
01892   ckarg(3);
01893   dbm=dbm_open(Getstring(argv[0])->c.str.chars,
01894                ckintval(argv[1]),
01895                ckintval(argv[2]));
01896   return(makeint(dbm));}
01897 
01898 pointer DBM_CLOSE(ctx,n,argv)
01899 register context *ctx;
01900 int n;
01901 register pointer argv[];
01902 { ckarg(1);
01903   dbm_close(ckintval(argv[0]));
01904   return(T);}
01905 
01906 pointer DBM_FETCH(ctx,n,argv)
01907 register context *ctx;
01908 int n;
01909 register pointer argv[];
01910 { register pointer s;
01911   datum key,content;
01912   ckarg(2);
01913   s=Getstring(argv[1]);
01914   key.dptr=(char *)(s->c.str.chars);
01915   key.dsize=strlength(s);
01916   content=dbm_fetch(ckintval(argv[0]), key);
01917   if (content.dptr==NULL) return(NIL);
01918   return(makestring(content.dptr,content.dsize));}
01919 
01920 pointer DBM_STORE(ctx,n,argv)
01921 register context *ctx;
01922 int n;
01923 register pointer argv[];
01924 { register pointer s;
01925   datum key,content;
01926   ckarg(4);
01927   s=Getstring(argv[1]);
01928   key.dptr=(char *)s->c.str.chars;
01929   key.dsize=strlength(s);
01930   s=Getstring(argv[2]);
01931   content.dptr=(char *)s->c.str.chars;
01932   content.dsize=strlength(s);
01933   n=dbm_store(ckintval(argv[0]), key, content, ckintval(argv[3]));
01934   return((n==0)?T:NIL);}
01935 
01936 pointer DBM_DELETE(ctx,n,argv)
01937 register context *ctx;
01938 int n;
01939 register pointer argv[];
01940 { register pointer s;
01941   datum key;
01942   ckarg(2);
01943   s=Getstring(argv[1]);
01944   key.dptr=(char *)s->c.str.chars;
01945   key.dsize=strlength(s);
01946   n=dbm_delete(ckintval(argv[0]), key);
01947   return((n==0)?T:NIL);}
01948 
01949 pointer DBM_FIRSTKEY(ctx,n,argv)
01950 register context *ctx;
01951 int n;
01952 register pointer argv[];
01953 { datum key;
01954   ckarg(1);
01955   key=dbm_firstkey(ckintval(argv[0]), key);
01956   if (key.dptr==NULL) return(NIL);
01957   return(makestring(key.dptr,key.dsize));}
01958 
01959 pointer DBM_NEXTKEY(ctx,n,argv)
01960 register context *ctx;
01961 int n;
01962 register pointer argv[];
01963 { datum key;
01964   ckarg(1);
01965   key=dbm_nextkey(ckintval(argv[0]), key);
01966   if (key.dptr==NULL) return(NIL);
01967   return(makestring(key.dptr,key.dsize));}
01968 
01969 pointer DBM_ERROR(ctx,n,argv)
01970 register context *ctx;
01971 int n;
01972 register pointer argv[];
01973 { ckarg(1);
01974   n=dbm_error((DBM *)ckintval(argv[0]));
01975   return((n==0)?T:NIL);}
01976 
01977 pointer DBM_CLEARERR(ctx,n,argv)
01978 register context *ctx;
01979 int n;
01980 register pointer argv[];
01981 { ckarg(1);
01982   dbm_clearerr((DBM *)ckintval(argv[0]));
01983   return(T);}
01984 
01985 #endif  /*sun3 || sun4*/
01986 #endif  /*ifdef DBM*/
01987 
01988 
01989 /* initialization of unixcall functions*/
01990 void unixcall(ctx,mod)
01991 register context *ctx;
01992 pointer mod;
01993 { pointer p=Spevalof(PACKAGE);
01994 
01995   Spevalof(PACKAGE)=unixpkg;
01996 
01997 /* common to unix and to vxworks */
01998   defun(ctx,"SIGADDSET",mod,SIGADDSET,NULL);
01999   defun(ctx,"SIGDELSET",mod,SIGDELSET,NULL);
02000   defun(ctx,"SIGPROCMASK",mod,SIGPROCMASK,NULL);
02001   defun(ctx,"KILL",mod,KILL,NULL);
02002   defun(ctx,"SIGNAL",mod,SIGNAL,NULL);
02003   defun(ctx,"EXIT",mod,EXIT,NULL);
02004   defun(ctx,"_EXIT",mod,_EXIT,NULL);
02005   defun(ctx,"GETPID",mod,GETPID,NULL);
02006   defun(ctx,"UREAD",mod,UNIXREAD,NULL);
02007   defun(ctx,"WRITE",mod,UNIXWRITE,NULL);
02008   defun(ctx,"UCLOSE",mod,UNIXCLOSE,NULL);
02009   defun(ctx,"IOCTL",mod,IOCTL,NULL);
02010   defun(ctx,"LSEEK",mod,LSEEK,NULL);
02011   defun(ctx,"SBRK",mod,SBRK,NULL);
02012   defun(ctx,"MALLOC",mod,MALLOC,NULL);
02013   defun(ctx,"FREE",mod,FREE,NULL);
02014 
02015   defun(ctx,"SOCKET",mod,SOCKET,NULL);
02016   defun(ctx,"BIND",mod,BIND,NULL);
02017   defun(ctx,"CONNECT",mod,CONNECT,NULL);
02018   defun(ctx,"LISTEN",mod,LISTEN,NULL);
02019   defun(ctx,"ACCEPT",mod,ACCEPT,NULL);
02020   defun(ctx,"SENDTO",mod,SENDTO,NULL);
02021   defun(ctx,"RECVFROM",mod,RECVFROM,NULL);
02022 #if !Solaris2
02023   defun(ctx,"GETPEERNAME",mod,GETPEERNAME,NULL);
02024 #endif
02025 /* #endif /*socket*/
02026 
02027 /*not supported by vxworks*/
02028 #if !vxworks
02029   defun(ctx,"PTIMES",mod,PTIMES,NULL);
02030   defun(ctx,"RUNTIME",mod,RUNTIME,NULL);
02031   defun(ctx,"LOCALTIME",mod,LOCALTIME,NULL);
02032   defun(ctx,"ASCTIME",mod,ASCTIME,NULL);
02033   defun(ctx,"GETITIMER",mod,GETITIMER,NULL);
02034   defun(ctx,"SETITIMER",mod,SETITIMER,NULL);
02035 
02036 #if !Solaris2
02037   defun(ctx,"GETRUSAGE",mod,GETRUSAGE,NULL);
02038   defun(ctx,"GETPAGESIZE",mod,GETPAGESIZE,NULL);
02039 #endif
02040 
02041   defun(ctx,"GETTIMEOFDAY",mod,GETTIMEOFDAY,NULL);
02042   defun(ctx,"ALARM",mod,ALARM,NULL);
02043 
02044 #if sun3 || sun4 || news || sanyo || alpha || x86_64 || ARM /* why i386 does not exist? */
02045 #if !Solaris2
02046   defun(ctx,"UALARM",mod,UALARM,NULL);
02047 #endif
02048 #endif
02049 
02050   defun(ctx,"WAIT",mod,WAIT,NULL);
02051   defun(ctx,"FORK",mod,FORK,NULL);
02052 #if Solaris2
02053   defun(ctx,"FORK1",mod,FORK1,NULL);
02054 #endif
02055   defun(ctx,"GETPPID",mod,GETPPID,NULL);
02056   defun(ctx,"GETPGRP",mod,GETPGRP,NULL);
02057   defun(ctx,"SETPGRP",mod,SETPGRP,NULL);
02058   defun(ctx,"GETUID",mod,GETUID,NULL);
02059   defun(ctx,"GETEUID",mod,GETEUID,NULL);
02060   defun(ctx,"GETGID",mod,GETGID,NULL);
02061   defun(ctx,"GETEGID",mod,GETEGID,NULL);
02062   defun(ctx,"SETUID",mod,SETUID,NULL);
02063   defun(ctx,"SETGID",mod,SETGID,NULL);
02064   defun(ctx,"MKNOD",mod,MKNOD,NULL);
02065   defun(ctx,"MKDIR",mod,MKDIR,NULL);
02066 #if !Cygwin /* Cygwin does not have LOCKF */
02067   defun(ctx,"LOCKF",mod,LOCKF,NULL);
02068 #endif
02069   defun(ctx,"FCNTL",mod,FCNTL,NULL);
02070 #if !Solaris2
02071   defun(ctx,"IOCTL_",mod,IOCTL_,NULL);
02072   defun(ctx,"IOCTL_R",mod,IOCTL_R,NULL);
02073   defun(ctx,"IOCTL_W",mod,IOCTL_W,NULL);
02074 #if !Cygwin /* Cygwin does not have IOCTL_WR */
02075   defun(ctx,"IOCTL_WR",mod,IOCTL_WR,NULL);
02076 #endif
02077 #endif
02078   defun(ctx,"DUP",mod,DUP,NULL);
02079   defun(ctx,"DUP2",mod,DUP2,NULL);
02080   defun(ctx,"SYSTEM",mod,SYSTEM,NULL);
02081   defun(ctx,"GETWD",mod,GETWD,NULL);
02082   defun(ctx,"GETENV",mod,GETENV,NULL);
02083   defun(ctx,"ENVIRON",mod,ENVIRON,NULL);
02084   defun(ctx,"SLEEP",mod,SLEEP,NULL);
02085   defun(ctx,"ERRNO",mod,ERRNO,NULL);
02086   defun(ctx,"PERROR",mod,PERROR,NULL);
02087   defun(ctx,"SYSERRLIST",mod,SYSERRLIST,NULL);
02088   defun(ctx,"PAUSE",mod,PAUSE,NULL);
02089   defun(ctx,"ISATTY",mod,ISATTY,NULL);
02090   defun(ctx,"LINK",mod,LINK,NULL);
02091   defun(ctx,"UNLINK",mod,UNLINK,NULL);
02092   defun(ctx,"RMDIR",mod,RMDIR,NULL);
02093   defun(ctx,"RENAME",mod,RENAME,NULL);
02094   defun(ctx,"ACCESS",mod,ACCESS,NULL);
02095 /*   defun(ctx,"FLOCK",mod,FLOCK,NULL); */
02096   defun(ctx,"STAT",mod,STAT,NULL);
02097   defun(ctx,"CHDIR",mod,CHDIR,NULL);
02098   defun(ctx,"CHMOD",mod,CHMOD,NULL);
02099   defun(ctx,"CHOWN",mod,CHOWN,NULL);
02100   defun(ctx,"PIPE",mod,PIPE,NULL);
02101   defun(ctx,"SELECT",mod,SELECT,NULL);
02102   defun(ctx,"SELECT-READ-FD",mod,SELECT_READ,NULL);
02103   defun(ctx,"READDIR",mod,DIRECTORY,NULL);
02104 
02105 #if !vxworks
02106   defun(ctx,"GETHOSTNAME",mod,GETHOSTNAME,NULL);
02107   defun(ctx,"GETHOSTBYNAME",mod,GETHOSTBYNAME,NULL);
02108   defun(ctx,"GETHOSTBYADDR",mod,GETHOSTBYADDR,NULL);
02109 #if !Cygwin /* Cygwin does not have GETNETBYNMAE */
02110   defun(ctx,"GETNETBYNAME",mod,GETNETBYNAME,NULL);
02111 #endif
02112   defun(ctx,"GETPROTOBYNAME",mod,GETPROTOBYNAME,NULL);
02113   defun(ctx,"GETSERVBYNAME",mod,GETSERVBYNAME,NULL);
02114 /* Append by I.Hara for IPC */
02115   defun(ctx,"HTONS",mod,H2NS,NULL);
02116   defun(ctx,"NTOHS",mod,N2HS,NULL);
02117 #endif
02118 
02119 #if sun3 || sun4 || vax || news || sanyo || (mips && !IRIX && !IRIX6) || i386 || alpha || x86_64 || ARM
02120   defun(ctx,"VFORK",mod,VFORK,NULL);
02121 #endif
02122   defun(ctx,"EXEC",mod,EXEC,NULL);
02123 #if !Solaris2 && !Cygwin
02124   defun(ctx,"GETPRIORITY",mod,GETPRIORITY,NULL);
02125   defun(ctx,"SETPRIORITY",mod,SETPRIORITY,NULL);
02126 #endif
02127 
02128 #if sun3 || sun4 || vax || mips || i386 || alpha || x86_64 || ARM
02129   defun(ctx,"PUTENV",mod,PUTENV,NULL);
02130 #endif
02131 #if sun3 || sun4 && !Solaris2 || Linux || alpha || Cygwin
02132   defun(ctx,"USLEEP",mod,USLEEP,NULL);
02133 #endif
02134 
02135 #if !news
02136   defun(ctx,"MSGGET",mod,MSGGET,NULL);
02137   defun(ctx,"MSGSND",mod,MSGSND,NULL);
02138   defun(ctx,"MSGRCV",mod,MSGRCV,NULL);
02139   defun(ctx,"MSGCTL",mod,MSGCTL,NULL);
02140 #endif
02141 
02142 #if sun3 || sun4 || news || alpha
02143   defun(ctx,"VALLOC",mod,VALLOC,NULL);
02144 #endif
02145 #if sun3 || sun4 || news || alpha || Linux || Cygwin
02146   defun(ctx,"MMAP",mod,MMAP,NULL);
02147   defun(ctx,"MUNMAP",mod,MUNMAP,NULL);
02148 /*  defun(ctx,"VADVISE",mod,VADVISE,NULL); */
02149 #endif
02150 
02151 #if system5 || Linux || Cygwin
02152   defun(ctx,"UNAME",mod,UNAME,NULL);
02153 #endif
02154 
02155 #endif /*socket*/
02156 
02157 /*ndbm libraries*/
02158 #ifdef DBM
02159 #if sun3 || sun4
02160   defun(ctx,"DBM-OPEN",mod,DBM_OPEN,NULL);
02161   defun(ctx,"DBM-CLOSE",mod,DBM_CLOSE,NULL);
02162   defun(ctx,"DBM-FETCH",mod,DBM_FETCH,NULL);
02163   defun(ctx,"DBM-STORE",mod,DBM_STORE,NULL);
02164   defun(ctx,"DBM-DELETE",mod,DBM_DELETE,NULL);
02165   defun(ctx,"DBM-FIRSTKEY",mod,DBM_FIRSTKEY,NULL);
02166   defun(ctx,"DBM-NEXTKEY",mod,DBM_NEXTKEY,NULL);
02167   defun(ctx,"DBM-ERROR",mod,DBM_ERROR,NULL);
02168   defun(ctx,"DBM-CLEARERR",mod,DBM_CLEARERR,NULL);
02169 #endif
02170 
02171 #endif
02172 /* restore package*/  pointer_update(Spevalof(PACKAGE),p);
02173 }


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Jun 6 2019 18:05:53