source: trunk/source/lisp-kernel/windows-calls.c @ 13025

Last change on this file since 13025 was 13025, checked in by gb, 10 years ago

lisp_open: don't ask for more than some combination of GENERIC_READ/
GENERIC_WRITE access.

File size: 20.9 KB
Line 
1/*
2   Copyright (C) 2008, Clozure Associates and contributors,
3   This file is part of Clozure CL. 
4
5   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
6   License , known as the LLGPL and distributed with Clozure CL as the
7   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
8   which is distributed with Clozure CL as the file "LGPL".  Where these
9   conflict, the preamble takes precedence. 
10
11   Clozure CL is referenced in the preamble as the "LIBRARY."
12
13   The LLGPL is also available online at
14   http://opensource.franz.com/preamble.html
15*/
16
17#include "lisp.h"
18#include "x86-exceptions.h"
19#include <io.h>
20#include <unistd.h>
21#include <sys/fcntl.h>
22#include <errno.h>
23#include <sys/stat.h>
24#include <windows.h>
25#include <psapi.h>
26#include <dirent.h>
27#include <signal.h>
28#undef __argv
29#include <stdio.h>
30#include <math.h>
31
32#ifndef WIN_32
33#define _dosmaperr mingw_dosmaperr
34#else
35void
36_dosmaperr(unsigned long oserrno)
37{
38  switch(oserrno) {
39  case  ERROR_INVALID_FUNCTION:
40    errno = EINVAL;
41    break;
42  case ERROR_FILE_NOT_FOUND:
43    errno = ENOENT;
44    break;
45  case ERROR_PATH_NOT_FOUND:
46    errno = ENOENT;
47    break;
48  case  ERROR_TOO_MANY_OPEN_FILES:
49    errno = EMFILE;
50    break;
51  case  ERROR_ACCESS_DENIED:
52    errno = EACCES;
53    break;
54  case  ERROR_ARENA_TRASHED:
55    errno = ENOMEM;
56    break;
57  case  ERROR_NOT_ENOUGH_MEMORY:
58    errno = ENOMEM;
59    break;
60  case  ERROR_INVALID_BLOCK:
61    errno = ENOMEM;
62    break;
63  case  ERROR_BAD_ENVIRONMENT:
64    errno = E2BIG;
65    break;
66  case  ERROR_BAD_FORMAT:
67    errno = ENOEXEC;
68    break;
69  case  ERROR_INVALID_ACCESS:
70    errno = EINVAL;
71    break;
72  case  ERROR_INVALID_DATA:
73    errno = EINVAL;
74    break;
75  case  ERROR_INVALID_DRIVE:
76    errno = ENOENT;
77    break;
78  case  ERROR_CURRENT_DIRECTORY:
79    errno = EACCES;
80    break;
81  case  ERROR_NOT_SAME_DEVICE:
82    errno = EXDEV;
83    break;
84  case  ERROR_NO_MORE_FILES:
85    errno = ENOENT;
86    break;
87  case  ERROR_LOCK_VIOLATION:
88    errno = EACCES;
89    break;
90  case  ERROR_BAD_NETPATH:
91    errno = ENOENT;
92    break;
93  case  ERROR_NETWORK_ACCESS_DENIED:
94    errno = EACCES;
95    break;
96  case  ERROR_BAD_NET_NAME:
97    errno = ENOENT;
98    break;
99  case  ERROR_FILE_EXISTS:
100    errno = EEXIST;
101    break;
102  case  ERROR_CANNOT_MAKE:
103    errno = EACCES;
104    break;
105  case  ERROR_FAIL_I24:
106    errno = EACCES;
107    break;
108  case  ERROR_INVALID_PARAMETER:
109    errno = EINVAL;
110    break;
111  case  ERROR_NO_PROC_SLOTS:
112    errno = EAGAIN;
113    break;
114  case  ERROR_DRIVE_LOCKED:
115    errno = EACCES;
116    break;
117  case  ERROR_BROKEN_PIPE:
118    errno = EPIPE;
119    break;
120  case  ERROR_DISK_FULL:
121    errno = ENOSPC;
122    break;
123  case  ERROR_INVALID_TARGET_HANDLE:
124    errno = EBADF;
125    break;
126  case  ERROR_INVALID_HANDLE:
127    errno = EINVAL;
128    break;
129  case  ERROR_WAIT_NO_CHILDREN:
130    errno = ECHILD;
131    break;
132  case  ERROR_CHILD_NOT_COMPLETE:
133    errno = ECHILD;
134    break;
135  case  ERROR_DIRECT_ACCESS_HANDLE:
136    errno = EBADF;
137    break;
138  case  ERROR_NEGATIVE_SEEK:
139    errno = EINVAL;
140    break;
141  case  ERROR_SEEK_ON_DEVICE:   
142    errno = EACCES;
143    break;
144  case  ERROR_DIR_NOT_EMPTY:
145    errno = ENOTEMPTY;
146    break;
147  case  ERROR_NOT_LOCKED:
148    errno = EACCES;
149    break;
150  case  ERROR_BAD_PATHNAME:
151    errno = ENOENT;
152    break;
153  case  ERROR_MAX_THRDS_REACHED:
154    errno = EAGAIN;
155    break;
156  case  ERROR_LOCK_FAILED:
157    errno = EACCES;
158    break;
159  case  ERROR_ALREADY_EXISTS:
160    errno = EEXIST;
161    break;
162  case  ERROR_FILENAME_EXCED_RANGE:
163    errno = ENOENT;
164    break;
165  case  ERROR_NESTING_NOT_ALLOWED:
166    errno = EAGAIN;
167    break;
168  case  ERROR_NOT_ENOUGH_QUOTA:
169    errno = ENOMEM;
170    break;
171  case ERROR_OPERATION_ABORTED:
172    errno = EINTR;
173    break;
174  default:
175    errno = EINVAL;
176    break;
177  }
178}
179   
180#endif
181
182#define MAX_FD 32
183
184HANDLE
185lisp_open(wchar_t *path, int flag, int mode)
186{
187  HANDLE hfile;
188  DWORD dwDesiredAccess = 0;
189  DWORD dwShareMode = 0;
190  DWORD dwCreationDistribution = 0;
191  DWORD dwFlagsAndAttributes = 0;
192  SECURITY_ATTRIBUTES sa = {sizeof(SECURITY_ATTRIBUTES), NULL, TRUE};
193
194  dwShareMode = FILE_SHARE_READ | FILE_SHARE_WRITE | FILE_SHARE_DELETE;
195
196  if ((flag & _O_WRONLY) == _O_WRONLY) {
197    dwDesiredAccess |= GENERIC_WRITE;
198  } else if ((flag & _O_RDWR) == _O_RDWR) {
199    dwDesiredAccess |= GENERIC_WRITE|GENERIC_READ;
200  } else {
201    dwDesiredAccess |= GENERIC_READ;
202  }
203   
204
205  if ((flag & (_O_CREAT | _O_EXCL)) == (_O_CREAT | _O_EXCL)) {
206    dwCreationDistribution |= CREATE_NEW;
207  } else if ((flag &  O_TRUNC) == O_TRUNC) {
208    if ((flag &  O_CREAT) ==  O_CREAT) {
209      dwCreationDistribution |= CREATE_ALWAYS;
210    } else if ((flag & O_RDONLY) != O_RDONLY) {
211      dwCreationDistribution |= TRUNCATE_EXISTING;
212    }
213  } else if ((flag & _O_APPEND) == _O_APPEND) {
214    dwCreationDistribution |= OPEN_EXISTING;
215  } else if ((flag &  _O_CREAT) == _O_CREAT) {
216    dwCreationDistribution |= OPEN_ALWAYS;
217  } else {
218    dwCreationDistribution |= OPEN_EXISTING;
219  }
220  if ((flag &  _O_RANDOM) == _O_RANDOM) {
221    dwFlagsAndAttributes |= FILE_FLAG_RANDOM_ACCESS;
222  }
223  if ((flag &  _O_SEQUENTIAL) == _O_SEQUENTIAL) {
224    dwFlagsAndAttributes |= FILE_FLAG_SEQUENTIAL_SCAN;
225  }
226
227  if ((flag &  _O_TEMPORARY) == _O_TEMPORARY) {
228    dwFlagsAndAttributes |= FILE_FLAG_DELETE_ON_CLOSE;
229  }
230
231  if ((flag &  _O_SHORT_LIVED) == _O_SHORT_LIVED) {
232    dwFlagsAndAttributes |= FILE_FLAG_DELETE_ON_CLOSE;
233  }
234
235  if (flag & _O_NOINHERIT) {
236    sa.bInheritHandle = FALSE;
237  }
238
239#if 0
240  dwFlagsAndAttributes |= FILE_FLAG_OVERLAPPED;
241#endif
242   
243
244  hfile = CreateFileW(path,
245                      dwDesiredAccess,
246                      dwShareMode,
247                      &sa,
248                      dwCreationDistribution,
249                      dwFlagsAndAttributes,
250                      NULL);
251  if (hfile == ((HANDLE)-1)) {
252    _dosmaperr(GetLastError());
253    return (HANDLE)-1;
254  }
255  return hfile;
256}
257
258int
259wopen(wchar_t *path, int flag, int mode)
260{
261  HANDLE h = lisp_open(path, flag, mode);
262
263  if (h == (HANDLE)-1) {
264    return -1;                  /* errno already set */
265  }
266  return  _open_osfhandle((intptr_t)h,0);
267}
268
269int
270lisp_close(HANDLE hfile)
271{
272  int err;
273
274  if (closesocket((SOCKET)hfile) == 0) {
275    return 0;
276  }
277
278  err = WSAGetLastError();
279  if (err != WSAENOTSOCK) {
280    _dosmaperr(err);
281    return -1;
282  }
283  if (CloseHandle(hfile)) {
284    return 0;
285  }
286  _dosmaperr(GetLastError());
287  return -1;
288}
289
290extern TCR *get_tcr(int);
291
292ssize_t
293lisp_standard_read(HANDLE hfile, void *buf, unsigned int count)
294{
295  HANDLE hevent;
296  OVERLAPPED overlapped;
297  DWORD err, nread, wait_result;
298  pending_io pending;
299  TCR *tcr;
300 
301 
302  memset(&overlapped,0,sizeof(overlapped));
303
304  if (GetFileType(hfile) == FILE_TYPE_DISK) {
305    overlapped.Offset = SetFilePointer(hfile, 0, &(overlapped.OffsetHigh), FILE_CURRENT);
306  }
307
308  tcr = (TCR *)get_tcr(1);
309  pending.h = hfile;
310  pending.o = &overlapped;
311  tcr->pending_io_info = &pending;
312  hevent = (HANDLE)(tcr->io_datum);
313  overlapped.hEvent = hevent;
314  ResetEvent(hevent);
315  if (ReadFile(hfile, buf, count, &nread, &overlapped)) {
316    tcr->pending_io_info = NULL;
317    return nread;
318  }
319
320  err = GetLastError();
321 
322  if (err == ERROR_HANDLE_EOF) {
323    tcr->pending_io_info = NULL;
324    return 0;
325  }
326
327  if (err != ERROR_IO_PENDING) {
328    _dosmaperr(err);
329    tcr->pending_io_info = NULL;
330    return -1;
331  }
332 
333  err = 0;
334 
335  /* We block here */   
336  wait_result = WaitForSingleObjectEx(hevent, INFINITE, true);
337
338
339
340  tcr->pending_io_info = NULL;
341  if (wait_result == WAIT_OBJECT_0) {
342    err = overlapped.Internal;
343    if (err == ERROR_HANDLE_EOF) {
344      return 0;
345    }
346    if (err) {
347      _dosmaperr(err);
348      return -1;
349    }
350    return overlapped.InternalHigh;
351  }
352
353  if (wait_result == WAIT_IO_COMPLETION) {
354    CancelIo(hfile);
355    errno = EINTR;
356    return -1;
357  }
358  err = GetLastError();
359 
360
361  switch (err) {
362  case ERROR_HANDLE_EOF: 
363    return 0;
364  default:
365    _dosmaperr(err);
366    return -1;
367  }
368}
369
370ssize_t
371pipe_read(HANDLE hfile, void *buf, unsigned int count)
372{
373  DWORD navail, err;;
374
375  do {
376    navail = 0;
377    if (PeekNamedPipe(hfile, NULL, 0, NULL, &navail, NULL) == 0) {
378      err = GetLastError();
379      if (err = ERROR_HANDLE_EOF) {
380        return 0;
381      } else {
382        _dosmaperr(err);
383        return -1;
384      }
385    }
386    if (navail != 0) {
387      return lisp_standard_read(hfile, buf, count);
388    }
389    if (SleepEx(50, TRUE) == WAIT_IO_COMPLETION) {
390      errno = EINTR;
391      return -1;
392    }
393  } while (1);
394}
395
396ssize_t
397console_read(HANDLE hfile, void *buf, unsigned int count)
398{
399  DWORD err, eventcount, i, n;
400  INPUT_RECORD ir;
401
402  do {
403    err = WaitForSingleObjectEx(hfile, INFINITE, TRUE);
404    switch (err) {
405    case WAIT_OBJECT_0:
406      eventcount = 0;
407      GetNumberOfConsoleInputEvents(hfile, &eventcount);
408      for (i = 0; i < eventcount; i++) {
409        PeekConsoleInput(hfile, &ir, 1, &n);
410        if (ir.EventType == KEY_EVENT) {
411          return lisp_standard_read(hfile, buf, count);
412        } else {
413          ReadConsoleInput(hfile, &ir, 1, &n);
414        }
415      }
416      break;
417    case WAIT_IO_COMPLETION:
418      errno = EINTR;
419      return -1;
420      break;
421    case WAIT_FAILED:
422      _dosmaperr(GetLastError());
423      return -1;
424      break;
425    }
426  } while (1);
427}
428
429ssize_t
430lisp_read(HANDLE hfile, void *buf, unsigned int count) {
431  switch(GetFileType(hfile)) {
432  case FILE_TYPE_CHAR:
433    return console_read(hfile, buf, count);
434    break;
435
436  case FILE_TYPE_PIPE:          /* pipe or one of these newfangled socket things */
437    {
438      int socktype, optlen = sizeof(int);
439      if ((getsockopt((SOCKET)hfile, SOL_SOCKET, SO_TYPE, (char *)&socktype, &optlen) != 0) && (GetLastError() == WSAENOTSOCK)) {
440        return pipe_read(hfile, buf, count);
441      }
442    }
443    /* It's a socket, fall through */
444   
445  case FILE_TYPE_DISK:
446    return lisp_standard_read(hfile, buf, count);
447    break;
448
449  default:
450    errno = EBADF;
451    return -1;
452  }
453}
454
455
456
457ssize_t
458lisp_write(HANDLE hfile, void *buf, ssize_t count)
459{
460  HANDLE hevent;
461  OVERLAPPED overlapped;
462  DWORD err, nwritten, wait_result;
463  pending_io pending;
464  TCR *tcr = (TCR *)get_tcr(1);
465
466  hevent = (HANDLE)tcr->io_datum;
467  if (hfile == (HANDLE)1) {
468    hfile = GetStdHandle(STD_OUTPUT_HANDLE);
469  } else if (hfile == (HANDLE) 2) {
470    hfile = GetStdHandle(STD_ERROR_HANDLE);
471  }
472
473
474  memset(&overlapped,0,sizeof(overlapped));
475
476  if (GetFileType(hfile) == FILE_TYPE_DISK) {
477    overlapped.Offset = SetFilePointer(hfile, 0, &(overlapped.OffsetHigh), FILE_CURRENT);
478  }
479
480
481  pending.h = hfile;
482  pending.o = &overlapped;
483  tcr->pending_io_info = &pending;
484  overlapped.hEvent = hevent;
485  ResetEvent(hevent);
486  if (WriteFile(hfile, buf, count, &nwritten, &overlapped)) {
487    tcr->pending_io_info = NULL;
488    return nwritten;
489  }
490 
491  err = GetLastError();
492  if (err != ERROR_IO_PENDING) {
493    _dosmaperr(err);
494    tcr->pending_io_info = NULL;
495    return -1;
496  }
497  err = 0;
498  wait_result = WaitForSingleObjectEx(hevent, INFINITE, true);
499  tcr->pending_io_info = NULL;
500  if (wait_result == WAIT_OBJECT_0) {
501    err = overlapped.Internal;
502    if (err) {
503      _dosmaperr(err);
504      return -1;
505    }
506    return overlapped.InternalHigh;
507  }
508  if (wait_result == WAIT_IO_COMPLETION) {
509    CancelIo(hfile);
510    errno = EINTR;
511    return -1;
512  }
513  err = GetLastError();
514  _dosmaperr(err);
515  return -1;
516}
517
518int
519lisp_fchmod(HANDLE hfile, int mode)
520{
521  errno = ENOSYS;
522  return -1;
523}
524
525__int64
526lisp_lseek(HANDLE hfile, __int64 offset, int whence)
527{
528  DWORD high, low;
529
530  high = ((__int64)offset)>>32;
531  low = offset & 0xffffffff;
532  low = SetFilePointer(hfile, low, &high, whence);
533  if (low != INVALID_SET_FILE_POINTER) {
534    return ((((__int64)high)<<32)|low);
535  }
536  _dosmaperr(GetLastError());
537  return -1;
538}
539
540#define ALL_USERS(f) ((f) | ((f)>> 3) | ((f >> 6)))
541#define STAT_READONLY ALL_USERS(_S_IREAD)
542#define STAT_READWRITE ALL_USERS((_S_IREAD|_S_IWRITE))
543int
544lisp_stat(wchar_t *path, struct __stat64 *buf)
545{
546  return _wstat64(path,buf);
547}
548
549#define UNIX_EPOCH_IN_WINDOWS_EPOCH  116444736000000000LL
550
551__time64_t
552filetime_to_unix_time(FILETIME *ft)
553{
554  __time64_t then = *((__time64_t *) ft);
555
556  then -= UNIX_EPOCH_IN_WINDOWS_EPOCH;
557  return then/10000000;
558}
559
560int
561lisp_fstat(HANDLE hfile, struct __stat64 *buf)
562{
563  int filetype;
564
565  filetype = GetFileType(hfile) & ~FILE_TYPE_REMOTE;
566
567  if (filetype == FILE_TYPE_UNKNOWN) {
568    errno = EBADF;
569    return -1;
570  }
571
572  memset(buf, 0, sizeof(*buf));
573  buf->st_nlink = 1;
574 
575  switch(filetype) {
576  case FILE_TYPE_CHAR:
577  case FILE_TYPE_PIPE:
578    if (filetype == FILE_TYPE_CHAR) {
579      buf->st_mode = _S_IFCHR;
580    } else {
581      buf->st_mode = _S_IFIFO;
582    }
583    break;
584  case FILE_TYPE_DISK:
585    {
586      BY_HANDLE_FILE_INFORMATION info;
587
588      if (!GetFileInformationByHandle(hfile, &info)) {
589        _dosmaperr(GetLastError());
590        return -1;
591      }
592
593      if (info.dwFileAttributes & FILE_ATTRIBUTE_READONLY) {
594        buf->st_mode = STAT_READONLY;
595      } else {
596        buf->st_mode = STAT_READWRITE;
597      }
598      buf->st_mode |= _S_IFREG;
599      buf->st_size = ((((__int64)(info.nFileSizeHigh))<<32LL) |
600                      ((__int64)(info.nFileSizeLow)));
601      buf->st_mtime = filetime_to_unix_time(&info.ftLastWriteTime);
602      buf->st_atime = filetime_to_unix_time(&info.ftLastAccessTime);
603      buf->st_ctime = filetime_to_unix_time(&info.ftCreationTime);
604    }
605    break;
606  case FILE_TYPE_UNKNOWN:
607  default:
608    errno = EBADF;
609    return -1;
610  }
611  return 0;
612}
613
614int
615lisp_futex(int *uaddr, int op, int val, void *timeout, int *uaddr2, int val3)
616{
617  errno = ENOSYS;
618  return -1;
619}
620
621
622__int64
623lisp_ftruncate(HANDLE hfile, off_t new_size)
624{
625  __int64 oldpos;
626
627
628  oldpos = lisp_lseek(hfile, 0, SEEK_END);
629  if (oldpos == -1) {
630    return 0;
631  }
632  if (oldpos < new_size) {
633    char buf[4096];
634    __int64 n = new_size-oldpos;
635    DWORD nwritten, to_write;
636
637    memset(buf,0,sizeof(buf));
638    while(n) {
639      if (n > 4096LL) {
640        to_write = 4096;
641      } else {
642        to_write = n;
643      }
644      if (!WriteFile(hfile,buf,to_write,&nwritten,NULL)) {
645        _dosmaperr(GetLastError());
646        return -1;
647      }
648      n -= nwritten;
649    }
650    return 0;
651  }
652  lisp_lseek(hfile, new_size, SEEK_SET);
653  if (SetEndOfFile(hfile)) {
654    return 0;
655  }
656  _dosmaperr(GetLastError());
657  return -1;
658}
659
660
661_WDIR *
662lisp_opendir(wchar_t *path)
663{
664  return _wopendir(path);
665}
666
667struct _wdirent *
668lisp_readdir(_WDIR *dir)
669{
670  return _wreaddir(dir);
671}
672
673__int64
674lisp_closedir(_WDIR *dir)
675{
676  return _wclosedir(dir);
677}
678
679int
680lisp_pipe(int fd[2])
681{
682  HANDLE input, output;
683  SECURITY_ATTRIBUTES sa;
684
685  sa.nLength= sizeof(SECURITY_ATTRIBUTES);
686  sa.lpSecurityDescriptor = NULL;
687  sa.bInheritHandle = TRUE;
688
689  if (!CreatePipe(&input, &output, &sa, 0))
690    {
691      wperror("CreatePipe");
692      return -1;
693    }
694  fd[0] = (int) ((intptr_t)input);
695  fd[1] = (int) ((intptr_t)output);
696  return 0;
697}
698
699int
700lisp_gettimeofday(struct timeval *tp, void *tzp)
701{
702  __time64_t now;
703
704  gettimeofday(tp,tzp);       /* trust it to get time zone right, at least */
705  GetSystemTimeAsFileTime((FILETIME*)&now);
706  now -= UNIX_EPOCH_IN_WINDOWS_EPOCH;
707  now /= 10000;               /* convert time to milliseconds */
708  tp->tv_sec = now/1000LL;
709  tp->tv_usec = 1000 * (now%1000LL); /* convert milliseconds to microseconds */
710  return 0;
711}
712
713int
714lisp_sigexit(int signum)
715{
716  signal(signum, SIG_DFL);
717  return raise(signum);
718}
719
720#ifdef WIN_64
721
722/* Make sure that the lisp calls these functions, when they do something */
723/* This code is taken from the 32-bit mingw library and is in the
724   public domain */
725double
726acosh(double x)
727{
728  if (isnan (x)) 
729    return x;
730
731  if (x < 1.0)
732    {
733      errno = EDOM;
734      return nan("");
735    }
736
737  if (x > 0x1p32)
738    /*  Avoid overflow (and unnecessary calculation when
739        sqrt (x * x - 1) == x). GCC optimizes by replacing
740        the long double M_LN2 const with a fldln2 insn.  */ 
741    return log (x) + 6.9314718055994530941723E-1L;
742
743  /* Since  x >= 1, the arg to log will always be greater than
744     the fyl2xp1 limit (approx 0.29) so just use logl. */ 
745  return log (x + sqrt((x + 1.0) * (x - 1.0)));
746}
747
748float
749acoshf(float x)
750{
751  if (isnan (x)) 
752    return x;
753  if (x < 1.0f)
754    {
755      errno = EDOM;
756      return nan("");
757    }
758
759 if (x > 0x1p32f)
760    /*  Avoid overflow (and unnecessary calculation when
761        sqrt (x * x - 1) == x). GCC optimizes by replacing
762        the long double M_LN2 const with a fldln2 insn.  */ 
763    return log (x) + 6.9314718055994530941723E-1L;
764
765  /* Since  x >= 1, the arg to log will always be greater than
766     the fyl2xp1 limit (approx 0.29) so just use logl. */ 
767  return log (x + sqrt((x + 1.0) * (x - 1.0)));
768}
769
770double
771asinh(double x)
772{
773  double z;
774  if (!isfinite (x))
775    return x;
776  z = fabs (x);
777
778  /* Avoid setting FPU underflow exception flag in x * x. */
779#if 0
780  if ( z < 0x1p-32)
781    return x;
782#endif
783
784  /* Use log1p to avoid cancellation with small x. Put
785     x * x in denom, so overflow is harmless.
786     asinh(x) = log1p (x + sqrt (x * x + 1.0) - 1.0)
787              = log1p (x + x * x / (sqrt (x * x + 1.0) + 1.0))  */
788
789  z = log1p (z + z * z / (sqrt (z * z + 1.0) + 1.0));
790
791  return ( x >= 0.0 ? z : -z);
792}
793
794float
795asinhf(float x)
796{
797  float z;
798  if (!isfinite (x))
799    return x;
800  z = fabsf (x);
801
802  /* Avoid setting FPU underflow exception flag in x * x. */
803#if 0
804  if ( z < 0x1p-32)
805    return x;
806#endif
807
808
809  /* Use log1p to avoid cancellation with small x. Put
810     x * x in denom, so overflow is harmless.
811     asinh(x) = log1p (x + sqrt (x * x + 1.0) - 1.0)
812              = log1p (x + x * x / (sqrt (x * x + 1.0) + 1.0))  */
813
814  z = log1p (z + z * z / (sqrt (z * z + 1.0) + 1.0));
815
816  return ( x >= 0.0 ? z : -z);
817}
818
819double
820atanh(double x)
821{
822  double z;
823  if (isnan (x))
824    return x;
825  z = fabs (x);
826  if (z == 1.0)
827    {
828      errno  = ERANGE;
829      return (x > 0 ? INFINITY : -INFINITY);
830    }
831  if (z > 1.0)
832    {
833      errno = EDOM;
834      return nan("");
835    }
836  /* Rearrange formula to avoid precision loss for small x.
837
838  atanh(x) = 0.5 * log ((1.0 + x)/(1.0 - x))
839           = 0.5 * log1p ((1.0 + x)/(1.0 - x) - 1.0)
840           = 0.5 * log1p ((1.0 + x - 1.0 + x) /(1.0 - x))
841           = 0.5 * log1p ((2.0 * x ) / (1.0 - x))  */
842  z = 0.5 * log1p ((z + z) / (1.0 - z));
843  return x >= 0 ? z : -z;
844}
845
846float
847atanhf(float x)
848{
849  float z;
850  if (isnan (x))
851    return x;
852  z = fabsf (x);
853  if (z == 1.0)
854    {
855      errno  = ERANGE;
856      return (x > 0 ? INFINITY : -INFINITY);
857    }
858  if ( z > 1.0)
859    {
860      errno = EDOM;
861      return nanf("");
862    }
863  /* Rearrange formula to avoid precision loss for small x.
864
865  atanh(x) = 0.5 * log ((1.0 + x)/(1.0 - x))
866           = 0.5 * log1p ((1.0 + x)/(1.0 - x) - 1.0)
867           = 0.5 * log1p ((1.0 + x - 1.0 + x) /(1.0 - x))
868           = 0.5 * log1p ((2.0 * x ) / (1.0 - x))  */
869  z = 0.5 * log1p ((z + z) / (1.0 - z));
870  return x >= 0 ? z : -z;
871}
872
873#endif
874
875typedef struct {
876  char *name;
877  void *addr;
878} math_fn_entry;
879
880
881math_fn_entry math_fn_entries [] = {
882  {"acos",acos},
883  {"acosf",acosf},
884  {"acosh",acosh},
885  {"acoshf",acoshf},
886  {"asin",asin},
887  {"asinf",asinf},
888  {"asinh",asinh},
889  {"asinhf",asinhf},
890  {"atan",atan},
891  {"atan2",atan2},
892  {"atan2f",atan2f},
893  {"atanf",atanf},
894  {"atanh",atanh},
895  {"atanhf",atanhf},
896  {"cos",cos},
897  {"cosf",cosf},
898  {"cosh",cosh},
899  {"coshf",coshf},
900  {"exp",exp},
901  {"expf",expf},
902  {"log",log},
903  {"logf",logf},
904  {"pow",pow},
905  {"powf",powf},
906  {"sin",sin},
907  {"sinf",sinf},
908  {"sinh",sinh},
909  {"sinhf",sinhf},
910  {"tan",tan},
911  {"tanf",tanf},
912  {"tanh",tanh},
913  {"tanhf",tanhf},
914  {NULL, 0}};
915
916void *
917lookup_math_fn(char *name)
918{
919  math_fn_entry *p = math_fn_entries;
920  char *entry_name;
921 
922  while ((entry_name = p->name) != NULL) {
923    if (!strcmp(name, entry_name)) {
924      return p->addr;
925    }
926    p++;
927  }
928  return NULL;
929}
930
931HMODULE *modules = NULL;
932DWORD cbmodules = 0;
933HANDLE find_symbol_lock = 0;
934
935void *
936windows_find_symbol(void *handle, char *name)
937{
938  void *addr;
939
940  if ((handle == ((void *)-2L)) ||
941      (handle == ((void *)-1L))) {
942    handle = NULL;
943  }
944  if (handle != NULL) {
945    addr = GetProcAddress(handle, name);
946  } else {
947    DWORD cbneeded,  have, i;
948    WaitForSingleObject(find_symbol_lock,INFINITE);
949
950    if (cbmodules == 0) {
951      cbmodules = 16 * sizeof(HANDLE);
952      modules = malloc(cbmodules);
953    }
954   
955    while (1) {
956      EnumProcessModules(GetCurrentProcess(),modules,cbmodules,&cbneeded);
957      if (cbmodules >= cbneeded) {
958        break;
959      }
960      cbmodules = cbneeded;
961      modules = realloc(modules,cbmodules);
962    }
963    have = cbneeded/sizeof(HANDLE);
964
965    for (i = 0; i < have; i++) {
966      addr = GetProcAddress(modules[i],name);
967
968      if (addr) {
969        break;
970      }
971    }
972    ReleaseMutex(find_symbol_lock);
973    if (addr) {
974      return addr;
975    }
976    return lookup_math_fn(name);
977  }
978}
979
980/* Note that we're using 8-bit strings here */
981
982void *
983windows_open_shared_library(char *path)
984{
985  HMODULE module = (HMODULE)0;
986
987  /* Try to open an existing module in a way that increments its
988     reference count without running any initialization code in
989     the dll. */
990  if (!GetModuleHandleExA(0,path,&module)) {
991    /* If that failed ... */
992    module = LoadLibraryA(path);
993  }
994  return (void *)module;
995}
996
997
998void
999init_windows_io()
1000{
1001#ifdef WIN_32
1002  extern void init_win32_ldt(void);
1003  init_win32_ldt();
1004#endif
1005  find_symbol_lock = CreateMutex(NULL,false,NULL);
1006}
1007
1008void
1009init_winsock()
1010{
1011  WSADATA data;
1012
1013  WSAStartup((2<<8)|2,&data);
1014}
1015
Note: See TracBrowser for help on using the repository browser.