ghc/lib/std/cbits/writeError.c

   1 /*
   2  * (c) The GRASP/AQUA Project, Glasgow University, 1998
   3  *
   4  * $Id: writeError.c,v 1.3 1999/11/05 15:22:59 simonmar Exp $
   5  *
   6  * hPutStr Runtime Support
   7  */
   8
   9 /*
  10 Writing out error messages. This is done outside Haskell
  11 (i.e., no use of the IO implementation is made), since it
  12 might be in an unstable state (e.g., hClose stderr >> error "foo")
  13
  14 (A secondary reason is that ``error'' is used by the IO
  15 implementation in one or two places.)
  16
  17 */
  18
  19 #include "Rts.h"
  20 #include "stgio.h"
  21
  22 #ifdef HAVE_FCNTL_H
  23 #include <fcntl.h>
  24 #endif
  25
  26 void
  27 writeErrString__ (msg_hdr, msg, len)
  28 StgAddr msg_hdr;
  29 StgByteArray msg;
  30 StgInt len;
  31 {
  32   int count = 0;
  33   char* p  = (char*)msg;
  34   char  nl = '\n';
  35   long fd_flags;
  36
  37 #if !defined(_WIN32) || defined(__CYGWIN__) || defined(__CYGWIN32__)
  38     /* clear the non-blocking flag on this file descriptor */
  39     fd_flags = fcntl(2, F_GETFL);
  40     fcntl(2, F_SETFL, fd_flags & ~O_NONBLOCK);
  41 #endif
  42
  43   /* Print error msg header */
  44   if (msg_hdr) {
  45     ((void (*)(int))msg_hdr)(2/*stderr*/);
  46   }
  47
  48   while ( (count = write(2,p,len)) < len) {
  49      if (errno != EINTR ) {
  50         return;
  51      }
  52      len -= count;
  53      p   += count;
  54   }
  55   write(2, &nl, 1);
  56 }