# Hilfsfunktionen für CLISP auf UNIX
# Bruno Haible 12.12.1994

#include "lispbibl.c"

# Betriebssystem-Funktion read sichtbar machen:
  #undef read

# ==============================================================================

#ifdef NEED_OWN_UALARM
# Ein Ersatz für die ualarm-Funktion.
  global unsigned int ualarm (unsigned int value, unsigned int interval);
  global unsigned int ualarm(value,interval)
    var reg1 unsigned int value;
    var reg2 unsigned int interval;
    { var struct itimerval itimer;
      itimer.it_value.tv_sec = floor(value,1000000);
      itimer.it_value.tv_usec = value % 1000000;
      itimer.it_interval.tv_sec = floor(interval,1000000);
      itimer.it_interval.tv_usec = interval % 1000000;
      setitimer(ITIMER_REAL,&itimer,NULL);
      return 0; # den Rückgabewert ignorieren wir immer.
    }
#endif

# ==============================================================================

#ifdef NEED_OWN_SELECT
# Ein Ersatz für die select-Funktion.
  global int select (int width, fd_set* readfds, fd_set* writefds, fd_set* exceptfds, struct timeval * timeout);
  global int select(width,readfds,writefds,exceptfds,timeout)
    var reg8 int width;
    var reg4 fd_set* readfds;
    var reg5 fd_set* writefds;
    var reg6 fd_set* exceptfds;
    var reg9 struct timeval * timeout;
    { var struct pollfd pollfd_bag[FD_SETSIZE];
      var reg1 struct pollfd * pollfd_ptr = &pollfd_bag[0];
      var reg7 int pollfd_count = 0;
      if (width<0) { errno = EINVAL; return -1; }
      if (width>FD_SETSIZE) { width = FD_SETSIZE; }
      { var reg3 int fd;
        for (fd=0; fd<width; fd++)
          { var reg2 short events = 0;
            if (!(readfds==NULL) && FD_ISSET(fd,readfds)) { events |= POLLIN; }
            if (!(writefds==NULL) && FD_ISSET(fd,writefds)) { events |= POLLOUT; }
            if (!(exceptfds==NULL) && FD_ISSET(fd,exceptfds)) { events |= POLLPRI; }
            if (events)
              { pollfd_ptr->fd = fd;
                pollfd_ptr->events = events;
                pollfd_ptr->revents = 0;
                pollfd_ptr++; pollfd_count++;
      }   }   }
     {var reg10 int poll_timeout = timeout->tv_sec * 1000 + timeout->tv_usec / (1000000/1000);
      var reg9 int result = poll(pollfd_count,&pollfd_bag[0],poll_timeout);
      if (result>=0)
        { pollfd_ptr = &pollfd_bag[0];
          until (pollfd_count == 0)
            { var reg3 int fd = pollfd_ptr->fd;
              var reg2 short revents = pollfd_ptr->revents;
              if (!(readfds==NULL) && (revents & POLLIN)) { FD_SET(fd,readfds); }
              if (!(writefds==NULL) && (revents & POLLOUT)) { FD_SET(fd,writefds); }
              if (!(exceptfds==NULL) && (revents & (POLLPRI|POLLERR|POLLHUP))) { FD_SET(fd,exceptfds); }
              pollfd_ptr++; pollfd_count--;
        }   }
      return result;
    }}
#endif

# ==============================================================================

#ifdef NEED_OWN_GETTIMEOFDAY
# Ein Ersatz für die gettimeofday-Funktion.
  global int gettimeofday (struct timeval * tp, struct timezone * tzp);
  global int gettimeofday(tp,tzp)
    var reg1 struct timeval * tp;
    var reg2 struct timezone * tzp;
    { var struct timeb timebuf;
      if (!((tp==NULL) && (tzp==NULL)))
        { ftime(&timebuf);
          if (!(tp==NULL))
            { tp->tv_sec = timebuf.time;
              tp->tv_usec = (long)(timebuf.millitm) * (1000000/1000);
            }
          if (!(tzp==NULL))
            { tzp->tz_minuteswest = timebuf.timezone;
              tzp->tz_dsttime = 0; # ??
            }
        }
      return 0;
    }
#endif

# ==============================================================================

#ifdef NEED_OWN_RENAME
# Ein Ersatz für die rename-Funktion.
  global int rename (char* oldpath, char* newpath);
  global int rename(oldpath,newpath)
    var reg2 char* oldpath;
    var reg3 char* newpath;
    { var reg1 int result;
      if ((result = access(oldpath,0)) < 0) # oldpath überhaupt da?
        { return result; }
      if ((result = access(newpath,0)) < 0) # newpath auch da?
        { if (!(errno==ENOENT)) return result; }
        else
        { # Überprüfe, ob oldpath und newpath dasselbe sind.
          # Dann darf nämlich nichts gelöscht werden!
          var struct stat oldstatbuf;
          var struct stat newstatbuf;
          if ((result = stat(oldpath,&oldstatbuf)) < 0) { return result; }
          if ((result = stat(newpath,&newstatbuf)) < 0) { return result; }
          if ((oldstatbuf.st_dev == newstatbuf.st_dev)
              && (oldstatbuf.st_ino == newstatbuf.st_ino)
             )
            { return 0; }
          if ((result = unlink(newpath)) < 0) # newpath löschen
            { return result; }
        }
      if ((result = link(oldpath,newpath)) < 0) # newpath neu anlegen
        { return result; }
      if ((result = unlink(oldpath)) < 0) # oldpath kann nun gelöscht werden
        { return result; }
      return 0;
    }
#endif

# ==============================================================================

#ifdef EINTR

#ifdef UNIX # EMUNIX und RISCOS brauchen das nicht

# Ein Wrapper um die open-Funktion.
  global int nonintr_open (OPEN_CONST char* path, int flags, MODE_T mode);
  global int nonintr_open(path,flags,mode)
    var reg2 OPEN_CONST char* path;
    var reg3 int flags;
    var reg4 MODE_T mode;
    { var reg1 int retval;
      do { retval = open(path,flags,mode); } while ((retval < 0) && (errno == EINTR));
      return retval;
    }

# Ein Wrapper um die close-Funktion.
  global int nonintr_close (int fd);
  global int nonintr_close(fd)
    var reg2 int fd;
    { var reg1 int retval;
      do { retval = close(fd); } while ((retval < 0) && (errno == EINTR));
      return retval;
    }

# Ein Wrapper um die ioctl-Funktion.
  #undef ioctl
  global int nonintr_ioctl (int fd, IOCTL_REQUEST_T request, CADDR_T arg);
  global int nonintr_ioctl(fd,request,arg)
    var reg2 int fd;
    var reg3 IOCTL_REQUEST_T request;
    var reg4 CADDR_T arg;
    { var reg1 int retval;
      do { retval = ioctl(fd,request,arg); } while ((retval != 0) && (errno == EINTR));
      return retval;
    }

#endif

#ifdef UNIX_TERM_TERMIOS

# Ein Wrapper um die tcsetattr-Funktion.
  global int nonintr_tcsetattr (int fd, int optional_actions, struct termios * tp);
  global int nonintr_tcsetattr(fd,optional_actions,tp)
    var reg2 int fd;
    var reg3 int optional_actions;
    var reg4 struct termios * tp;
    { var reg1 int retval;
      do { retval = tcsetattr(fd,optional_actions,tp); }
         while ((retval != 0) && (errno == EINTR));
      return retval;
    }

# Ein Wrapper um die tcdrain-Funktion.
  global int nonintr_tcdrain (int fd);
  global int nonintr_tcdrain(fd)
    var reg2 int fd;
    { var reg1 int retval;
      do { retval = tcdrain(fd); } while ((retval != 0) && (errno == EINTR));
      return retval;
    }

# Ein Wrapper um die tcflush-Funktion.
  global int nonintr_tcflush (int fd, int flag);
  global int nonintr_tcflush(fd,flag)
    var reg2 int fd;
    var reg3 int flag;
    { var reg1 int retval;
      do { retval = tcflush(fd,flag); } while ((retval != 0) && (errno == EINTR));
      return retval;
    }

#endif

#ifdef NEED_OWN_SIGINTERRUPT

# Ein Ersatz für die siginterrupt-Funktion.
  global int siginterrupt (int sig, int flag);
  global int siginterrupt (sig,flag)
    var reg1 int sig;
    var reg2 int flag;
    {
     #if defined(HAVE_SIGACTION)
      extern int sigaction (/* int sig, [const] struct sigaction * new, struct sigaction * old */);
      var struct sigaction sa;
      sigaction(sig,(struct sigaction *)NULL,&sa);
      #ifdef SA_INTERRUPT
      if (flag)
        { if (sa.sa_flags & SA_INTERRUPT) return 0;
          sa.sa_flags |= SA_INTERRUPT; # system calls will be interrupted
        }
        else
        { if (!(sa.sa_flags & SA_INTERRUPT)) return 0;
          sa.sa_flags &= ~ SA_INTERRUPT; # system calls will be restarted
        }
      #endif
      #ifdef SA_RESTART
      if (flag)
        { if (!(sa.sa_flags & SA_RESTART)) return 0;
          sa.sa_flags &= ~ SA_RESTART; # system calls will be interrupted
        }
        else
        { if (sa.sa_flags & SA_RESTART) return 0;
          sa.sa_flags |= SA_RESTART; # system calls will be restarted
        }
      #endif
      sigaction(sig,&sa,(struct sigaction *)NULL);
     #elif defined(HAVE_SIGVEC) && defined(SV_INTERRUPT)
      extern int sigvec (/* int sig, [const] struct sigvec * new, struct sigvec * old */);
      var struct sigvec sv;
      sigvec(sig,(struct sigvec *)NULL,&sv);
      if (flag)
        { if (sv.sv_flags & SV_INTERRUPT) return 0;
          sv.sv_flags |= SV_INTERRUPT; # system calls will be interrupted
        }
        else
        { if (!(sv.sv_flags & SV_INTERRUPT)) return 0;
          sv.sv_flags &= ~ SV_INTERRUPT; # system calls will be restarted
        }
      sigvec(sig,&sv,(struct sigvec *)NULL);
     #endif
      return 0; # den Rückgabewert ignorieren wir immer.
    }

#endif

#endif

# Ein Wrapper um die read-Funktion.
  global RETRWTYPE full_read (int fd, char* buf, RW_SIZE_T nbyte);
  global RETRWTYPE full_read (fd,buf,nbyte)
    var reg5 int fd;
    var reg4 char* buf;
    var reg2 RW_SIZE_T nbyte;
    { var reg1 RETRWTYPE retval;
      var reg3 RW_SIZE_T done = 0;
      until (nbyte==0)
        { retval = read(fd,buf,nbyte);
          if (retval == 0) break;
          elif (retval < 0)
            {
              #ifdef EINTR
              if (!(errno == EINTR))
              #endif
                #if defined(GENERATIONAL_GC) && defined(SPVW_MIXED)
                if (!((errno == EFAULT) && handle_fault_range(PROT_READ_WRITE,(aint)buf,(aint)buf+nbyte)))
                #endif
                  return retval;
            }
          else { buf += retval; done += (RW_SIZE_T)retval; nbyte -= (RW_SIZE_T)retval; }
        }
      return done;
    }

# Ein Wrapper um die write-Funktion.
  global RETRWTYPE full_write (int fd, WRITE_CONST char* buf, RW_SIZE_T nbyte);
  global RETRWTYPE full_write (fd,buf,nbyte)
    var reg5 int fd;
    var reg4 WRITE_CONST char* buf;
    var reg2 RW_SIZE_T nbyte;
    { var reg1 RETRWTYPE retval;
      var reg3 RW_SIZE_T done = 0;
      until (nbyte==0)
        { retval = write(fd,buf,nbyte);
          if (retval == 0) break;
          elif (retval < 0)
            {
              #ifdef EINTR
              if (!(errno == EINTR))
              #endif
                #if defined(GENERATIONAL_GC) && defined(SPVW_MIXED)
                if (!((errno == EFAULT) && handle_fault_range(PROT_READ,(aint)buf,(aint)buf+nbyte)))
                #endif
                  return retval;
            }
          else { buf += retval; done += (RW_SIZE_T)retval; nbyte -= (RW_SIZE_T)retval; }
        }
      return done;
    }

#ifdef PID_T

# Auf die Beendingung eines Child-Prozesses warten:
  global int wait2 (PID_T child);
  global int wait2(child)
    var reg2 PID_T child;
    { var int status = 0;
      # vgl. WAIT(2V) und #include <sys/wait.h> :
      #   WIFSTOPPED(status)  ==  ((status & 0xFF) == 0177)
      #   WEXITSTATUS(status)  == ((status & 0xFF00) >> 8)
      #ifdef HAVE_WAITPID
      loop
        { var reg1 int ergebnis = waitpid(child,&status,0);
          if (!(ergebnis == child))
            { if (ergebnis<0)
                { if (errno==EINTR) continue;
                  #ifdef ECHILD
                  if (errno==ECHILD) # Wenn der Child-Prozeß nicht mehr da ist,
                    { status = 0; break; } # ist er wohl korrekt beendet worden.
                  #endif
                }
              OS_error();
            }
          if (!((status & 0xFF) == 0177)) break; # Child-Prozeß beendet?
        }
      #else
      loop
        { var reg1 int ergebnis = wait(&status);
          if (ergebnis < 0)
            { if (errno==EINTR) continue;
              #ifdef ECHILD
              if (errno==ECHILD) # Wenn der Child-Prozeß nicht mehr da ist,
                { status = 0; break; } # ist er wohl korrekt beendet worden.
              #endif
              OS_error();
            }
          if ((ergebnis == child) && !((status & 0xFF) == 0177)) break; # Child-Prozeß beendet?
        }
      #endif
      return status;
    }

#endif

# ==============================================================================

#if defined(UNIX_LINUX) && (defined(FAST_FLOAT) || defined(FAST_DOUBLE))

# Damit Division durch 0.0 ein NaN und kein SIGFPE liefert:
# Entweder mit -lieee linken,
# oder libc-linux/sysdeps/linux/{i386,m68k}/ieee.c kopieren:

#include <fpu_control.h>

global unsigned short __fpu_control = _FPU_IEEE;

#endif

# ==============================================================================

#if defined(HAVE_MMAP) && defined(UNIX_CONVEX)

# Ein Wrapper um die mmap-Funktion.
  #undef mmap
  global RETMMAPTYPE fixed_mmap (MMAP_ADDR_T addr, MMAP_SIZE_T len, int prot, int flags, int fd, off_t off);
  global RETMMAPTYPE fixed_mmap(addr,len,prot,flags,fd,off)
    var reg2 MMAP_ADDR_T addr;
    var MMAP_SIZE_T len;
    var reg3 int prot;
    var reg5 int flags;
    var reg6 int fd;
    var reg4 off_t off;
    { if (fd < 0)
        # Brauche ein Handle auf ein reguläres File.
        { local var int regular_fd = -2;
          #define regular_file  "/tmp/lispdummy.mmap"
          if (regular_fd < -1)
            { regular_fd = open(regular_file,O_CREAT|O_TRUNC|O_RDWR,my_open_mask);
              if (regular_fd >= 0) { unlink(regular_file); }
            }
          if (regular_fd >= 0)
            { return mmap(addr,&len,prot,flags,regular_fd,off); }
        }
      return mmap(addr,&len,prot,flags|MAP_FILE,fd,off);
    }

# Ein Ersatz für die mprotect-Funktion.
  global int mprotect(addr,len,prot)
    var reg1 MMAP_ADDR_T addr;
    var MMAP_SIZE_T len;
    var reg2 int prot;
    { return mremap(addr,&len,prot,MAP_PRIVATE); }

#endif

# ==============================================================================

#ifdef UNIX_CONVEX

# The purpose of this hack is to minimize crashes when memory is tight.
global int __ap$sigblock (int sigmask) { return 0; }
global int __ap$sigstack (struct sigstack *ss, struct sigstack *oss) { return 0; }

#endif

# ==============================================================================

