initc.pp 3.3 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145
  1. {
  2. $Id$
  3. }
  4. unit initc;
  5. interface
  6. type libcint = longint;
  7. plibcint = ^libcint;
  8. {$LINKLIB cygwin}
  9. {$linklib kernel32}
  10. { this unit is just ment to run
  11. startup code to get C code to work correctly PM }
  12. function fpgetCerrno:libcint;
  13. procedure fpsetCerrno(err:libcint);
  14. {$ifndef ver1_0}
  15. property cerrno:libcint read fpgetCerrno write fpsetcerrno;
  16. {$endif}
  17. implementation
  18. uses
  19. windows;
  20. {$i textrec.inc}
  21. function geterrnolocation: Plibcint; cdecl;external name '___errno';
  22. function fpgetCerrno:libcint;
  23. begin
  24. fpgetCerrno:=geterrnolocation^;
  25. end;
  26. procedure fpsetCerrno(err:libcint);
  27. begin
  28. geterrnolocation^:=err;
  29. end;
  30. procedure cygwin_crt0(p : pointer);cdecl;external;
  31. {
  32. procedure do_global_dtors;cdecl;external;
  33. this does not work because
  34. do_global_dtors is a static C function PM
  35. it is inserted into the atexit chain,
  36. but how do we call this from FPC ???
  37. it seems to be done in exit function
  38. but that one ends with _exit that is system dependent !! }
  39. { avoid loading of cygwin _exit code
  40. so that exit returns
  41. apparently this is not enough anymore
  42. use longjmp instead PM }
  43. var
  44. entryjmpbuf,exitjmpbuf : jmp_buf;
  45. const
  46. exitjmpbufset : boolean = false;
  47. procedure _exit(status : longint);cdecl;
  48. begin
  49. if exitjmpbufset then
  50. longjmp(exitjmpbuf,1)
  51. else
  52. RunError(status);
  53. end;
  54. procedure C_exit(status : longint);cdecl;external name '_exit';
  55. const
  56. STD_INPUT_HANDLE = $fffffff6;
  57. STD_OUTPUT_HANDLE = $fffffff5;
  58. STD_ERROR_HANDLE = $fffffff4;
  59. procedure UpdateStdHandle(var t:TextRec;var stdHandle:Thandle;newHandle:Thandle);
  60. { Check if the stdHandle is the same as the one in the TextRec, then
  61. also update the TextRec }
  62. begin
  63. if t.Handle=stdHandle then
  64. t.Handle:=newHandle;
  65. stdHandle:=newHandle;
  66. end;
  67. function entry : longint;
  68. begin
  69. longjmp(entryjmpbuf,1);
  70. entry:=0;
  71. end;
  72. var
  73. ConsoleMode: DWORD;
  74. ConsoleModeValid : boolean;
  75. initialization
  76. ConsoleModeValid:=GetConsoleMode(GetStdHandle(STD_INPUT_HANDLE), @ConsoleMode);
  77. if setjmp(entryjmpbuf)=0 then
  78. begin
  79. cygwin_crt0(@entry);
  80. end;
  81. if ConsoleModeValid then
  82. SetConsoleMode(GetStdHandle(STD_INPUT_HANDLE), ConsoleMode);
  83. { Reinitialize std handles that can be changed }
  84. UpdateStdHandle(TextRec(Input),StdInputHandle,GetStdHandle(STD_INPUT_HANDLE));
  85. UpdateStdHandle(TextRec(Output),StdOutputHandle,GetStdHandle(STD_OUTPUT_HANDLE));
  86. TextRec(StdOut).Handle:=StdOutputHandle;
  87. UpdateStdHandle(TextRec(Stderr),StdErrorHandle,GetStdHandle(STD_ERROR_HANDLE));
  88. finalization
  89. { should we pass exit code ?
  90. its apparently only used by _exit so it doesn't matter PM }
  91. if setjmp(exitjmpbuf)=0 then
  92. begin
  93. exitjmpbufset:=true;
  94. { C_exit(errorcode);
  95. this code does not work correctly anymore
  96. C function _exit is not called at end of exit function
  97. thus the code of exit does not return at all
  98. disabled PM }
  99. end;
  100. end.
  101. {
  102. $Log$
  103. Revision 1.12 2004-09-14 20:08:58 hajny
  104. * use errno from cygwin (like in fixes branch)
  105. Revision 1.11 2004/09/12 17:41:40 hajny
  106. * hopefully fixed the problem with missing __error symbol
  107. Revision 1.10 2003/12/11 09:21:52 marco
  108. * patch from peter
  109. Revision 1.9 2003/11/03 09:42:28 marco
  110. * Peter's Cardinal<->Longint fixes patch
  111. Revision 1.8 2003/09/08 18:25:45 peter
  112. * popstack to cdecl
  113. Revision 1.7 2002/09/07 16:01:28 peter
  114. * old logs removed and tabs fixed
  115. }