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


euslisp
Author(s): Toshihiro Matsui
autogenerated on Thu Sep 3 2015 10:36:20