PageRenderTime 49ms CodeModel.GetById 20ms RepoModel.GetById 0ms app.codeStats 0ms

/libgfortran/runtime/error.c

https://bitbucket.org/vaporoid/gcc
C | 618 lines | 366 code | 127 blank | 125 comment | 48 complexity | dba9ad238c95f017894dcb2ffc44209b MD5 | raw file
Possible License(s): GPL-3.0, BSD-3-Clause, LGPL-2.0, GPL-2.0, LGPL-2.1, AGPL-1.0
  1. /* Copyright (C) 2002-2013 Free Software Foundation, Inc.
  2. Contributed by Andy Vaught
  3. This file is part of the GNU Fortran runtime library (libgfortran).
  4. Libgfortran is free software; you can redistribute it and/or modify
  5. it under the terms of the GNU General Public License as published by
  6. the Free Software Foundation; either version 3, or (at your option)
  7. any later version.
  8. Libgfortran is distributed in the hope that it will be useful,
  9. but WITHOUT ANY WARRANTY; without even the implied warranty of
  10. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
  11. GNU General Public License for more details.
  12. Under Section 7 of GPL version 3, you are granted additional
  13. permissions described in the GCC Runtime Library Exception, version
  14. 3.1, as published by the Free Software Foundation.
  15. You should have received a copy of the GNU General Public License and
  16. a copy of the GCC Runtime Library Exception along with this program;
  17. see the files COPYING3 and COPYING.RUNTIME respectively. If not, see
  18. <http://www.gnu.org/licenses/>. */
  19. #include "libgfortran.h"
  20. #include <assert.h>
  21. #include <string.h>
  22. #include <errno.h>
  23. #include <signal.h>
  24. #ifdef HAVE_UNISTD_H
  25. #include <unistd.h>
  26. #endif
  27. #include <stdlib.h>
  28. #ifdef HAVE_SYS_TIME_H
  29. #include <sys/time.h>
  30. #endif
  31. /* <sys/time.h> has to be included before <sys/resource.h> to work
  32. around PR 30518; otherwise, MacOS 10.3.9 headers are just broken. */
  33. #ifdef HAVE_SYS_RESOURCE_H
  34. #include <sys/resource.h>
  35. #endif
  36. #ifdef __MINGW32__
  37. #define HAVE_GETPID 1
  38. #include <process.h>
  39. #endif
  40. /* Termination of a program: F2008 2.3.5 talks about "normal
  41. termination" and "error termination". Normal termination occurs as
  42. a result of e.g. executing the end program statement, and executing
  43. the STOP statement. It includes the effect of the C exit()
  44. function.
  45. Error termination is initiated when the ERROR STOP statement is
  46. executed, when ALLOCATE/DEALLOCATE fails without STAT= being
  47. specified, when some of the co-array synchronization statements
  48. fail without STAT= being specified, and some I/O errors if
  49. ERR/IOSTAT/END/EOR is not present, and finally EXECUTE_COMMAND_LINE
  50. failure without CMDSTAT=.
  51. 2.3.5 also explains how co-images synchronize during termination.
  52. In libgfortran we have two ways of ending a program. exit(code) is
  53. a normal exit; calling exit() also causes open units to be
  54. closed. No backtrace or core dump is needed here. When something
  55. goes wrong, we have sys_abort() which tries to print the backtrace
  56. if -fbacktrace is enabled, and then dumps core; whether a core file
  57. is generated is system dependent. When aborting, we don't flush and
  58. close open units, as program memory might be corrupted and we'd
  59. rather risk losing dirty data in the buffers rather than corrupting
  60. files on disk.
  61. */
  62. /* Error conditions. The tricky part here is printing a message when
  63. * it is the I/O subsystem that is severely wounded. Our goal is to
  64. * try and print something making the fewest assumptions possible,
  65. * then try to clean up before actually exiting.
  66. *
  67. * The following exit conditions are defined:
  68. * 0 Normal program exit.
  69. * 1 Terminated because of operating system error.
  70. * 2 Error in the runtime library
  71. * 3 Internal error in runtime library
  72. *
  73. * Other error returns are reserved for the STOP statement with a numeric code.
  74. */
  75. /* Write a null-terminated C string to standard error. This function
  76. is async-signal-safe. */
  77. ssize_t
  78. estr_write (const char *str)
  79. {
  80. return write (STDERR_FILENO, str, strlen (str));
  81. }
  82. /* st_vprintf()-- vsnprintf-like function for error output. We use a
  83. stack allocated buffer for formatting; since this function might be
  84. called from within a signal handler, printing directly to stderr
  85. with vfprintf is not safe since the stderr locking might lead to a
  86. deadlock. */
  87. #define ST_VPRINTF_SIZE 512
  88. int
  89. st_vprintf (const char *format, va_list ap)
  90. {
  91. int written;
  92. char buffer[ST_VPRINTF_SIZE];
  93. #ifdef HAVE_VSNPRINTF
  94. written = vsnprintf(buffer, ST_VPRINTF_SIZE, format, ap);
  95. #else
  96. written = vsprintf(buffer, format, ap);
  97. if (written >= ST_VPRINTF_SIZE - 1)
  98. {
  99. /* The error message was longer than our buffer. Ouch. Because
  100. we may have messed up things badly, report the error and
  101. quit. */
  102. #define ERROR_MESSAGE "Internal error: buffer overrun in st_vprintf()\n"
  103. write (STDERR_FILENO, buffer, ST_VPRINTF_SIZE - 1);
  104. write (STDERR_FILENO, ERROR_MESSAGE, strlen(ERROR_MESSAGE));
  105. sys_abort ();
  106. #undef ERROR_MESSAGE
  107. }
  108. #endif
  109. written = write (STDERR_FILENO, buffer, written);
  110. return written;
  111. }
  112. int
  113. st_printf (const char * format, ...)
  114. {
  115. int written;
  116. va_list ap;
  117. va_start (ap, format);
  118. written = st_vprintf (format, ap);
  119. va_end (ap);
  120. return written;
  121. }
  122. /* sys_abort()-- Terminate the program showing backtrace and dumping
  123. core. */
  124. void
  125. sys_abort (void)
  126. {
  127. /* If backtracing is enabled, print backtrace and disable signal
  128. handler for ABRT. */
  129. if (options.backtrace == 1
  130. || (options.backtrace == -1 && compile_options.backtrace == 1))
  131. {
  132. estr_write ("\nProgram aborted. Backtrace:\n");
  133. backtrace ();
  134. signal (SIGABRT, SIG_DFL);
  135. }
  136. abort();
  137. }
  138. /* gfc_xtoa()-- Integer to hexadecimal conversion. */
  139. const char *
  140. gfc_xtoa (GFC_UINTEGER_LARGEST n, char *buffer, size_t len)
  141. {
  142. int digit;
  143. char *p;
  144. assert (len >= GFC_XTOA_BUF_SIZE);
  145. if (n == 0)
  146. return "0";
  147. p = buffer + GFC_XTOA_BUF_SIZE - 1;
  148. *p = '\0';
  149. while (n != 0)
  150. {
  151. digit = n & 0xF;
  152. if (digit > 9)
  153. digit += 'A' - '0' - 10;
  154. *--p = '0' + digit;
  155. n >>= 4;
  156. }
  157. return p;
  158. }
  159. /* Hopefully thread-safe wrapper for a strerror_r() style function. */
  160. char *
  161. gf_strerror (int errnum,
  162. char * buf __attribute__((unused)),
  163. size_t buflen __attribute__((unused)))
  164. {
  165. #ifdef HAVE_STRERROR_R
  166. /* POSIX returns an "int", GNU a "char*". */
  167. return
  168. __builtin_choose_expr (__builtin_classify_type (strerror_r (0, buf, 0))
  169. == 5,
  170. /* GNU strerror_r() */
  171. strerror_r (errnum, buf, buflen),
  172. /* POSIX strerror_r () */
  173. (strerror_r (errnum, buf, buflen), buf));
  174. #elif defined(HAVE_STRERROR_R_2ARGS)
  175. strerror_r (errnum, buf);
  176. return buf;
  177. #else
  178. /* strerror () is not necessarily thread-safe, but should at least
  179. be available everywhere. */
  180. return strerror (errnum);
  181. #endif
  182. }
  183. /* show_locus()-- Print a line number and filename describing where
  184. * something went wrong */
  185. void
  186. show_locus (st_parameter_common *cmp)
  187. {
  188. char *filename;
  189. if (!options.locus || cmp == NULL || cmp->filename == NULL)
  190. return;
  191. if (cmp->unit > 0)
  192. {
  193. filename = filename_from_unit (cmp->unit);
  194. if (filename != NULL)
  195. {
  196. st_printf ("At line %d of file %s (unit = %d, file = '%s')\n",
  197. (int) cmp->line, cmp->filename, (int) cmp->unit, filename);
  198. free (filename);
  199. }
  200. else
  201. {
  202. st_printf ("At line %d of file %s (unit = %d)\n",
  203. (int) cmp->line, cmp->filename, (int) cmp->unit);
  204. }
  205. return;
  206. }
  207. st_printf ("At line %d of file %s\n", (int) cmp->line, cmp->filename);
  208. }
  209. /* recursion_check()-- It's possible for additional errors to occur
  210. * during fatal error processing. We detect this condition here and
  211. * exit with code 4 immediately. */
  212. #define MAGIC 0x20DE8101
  213. static void
  214. recursion_check (void)
  215. {
  216. static int magic = 0;
  217. /* Don't even try to print something at this point */
  218. if (magic == MAGIC)
  219. sys_abort ();
  220. magic = MAGIC;
  221. }
  222. #define STRERR_MAXSZ 256
  223. /* os_error()-- Operating system error. We get a message from the
  224. * operating system, show it and leave. Some operating system errors
  225. * are caught and processed by the library. If not, we come here. */
  226. void
  227. os_error (const char *message)
  228. {
  229. char errmsg[STRERR_MAXSZ];
  230. recursion_check ();
  231. estr_write ("Operating system error: ");
  232. estr_write (gf_strerror (errno, errmsg, STRERR_MAXSZ));
  233. estr_write ("\n");
  234. estr_write (message);
  235. estr_write ("\n");
  236. exit (1);
  237. }
  238. iexport(os_error);
  239. /* void runtime_error()-- These are errors associated with an
  240. * invalid fortran program. */
  241. void
  242. runtime_error (const char *message, ...)
  243. {
  244. va_list ap;
  245. recursion_check ();
  246. estr_write ("Fortran runtime error: ");
  247. va_start (ap, message);
  248. st_vprintf (message, ap);
  249. va_end (ap);
  250. estr_write ("\n");
  251. exit (2);
  252. }
  253. iexport(runtime_error);
  254. /* void runtime_error_at()-- These are errors associated with a
  255. * run time error generated by the front end compiler. */
  256. void
  257. runtime_error_at (const char *where, const char *message, ...)
  258. {
  259. va_list ap;
  260. recursion_check ();
  261. estr_write (where);
  262. estr_write ("\nFortran runtime error: ");
  263. va_start (ap, message);
  264. st_vprintf (message, ap);
  265. va_end (ap);
  266. estr_write ("\n");
  267. exit (2);
  268. }
  269. iexport(runtime_error_at);
  270. void
  271. runtime_warning_at (const char *where, const char *message, ...)
  272. {
  273. va_list ap;
  274. estr_write (where);
  275. estr_write ("\nFortran runtime warning: ");
  276. va_start (ap, message);
  277. st_vprintf (message, ap);
  278. va_end (ap);
  279. estr_write ("\n");
  280. }
  281. iexport(runtime_warning_at);
  282. /* void internal_error()-- These are this-can't-happen errors
  283. * that indicate something deeply wrong. */
  284. void
  285. internal_error (st_parameter_common *cmp, const char *message)
  286. {
  287. recursion_check ();
  288. show_locus (cmp);
  289. estr_write ("Internal Error: ");
  290. estr_write (message);
  291. estr_write ("\n");
  292. /* This function call is here to get the main.o object file included
  293. when linking statically. This works because error.o is supposed to
  294. be always linked in (and the function call is in internal_error
  295. because hopefully it doesn't happen too often). */
  296. stupid_function_name_for_static_linking();
  297. exit (3);
  298. }
  299. /* translate_error()-- Given an integer error code, return a string
  300. * describing the error. */
  301. const char *
  302. translate_error (int code)
  303. {
  304. const char *p;
  305. switch (code)
  306. {
  307. case LIBERROR_EOR:
  308. p = "End of record";
  309. break;
  310. case LIBERROR_END:
  311. p = "End of file";
  312. break;
  313. case LIBERROR_OK:
  314. p = "Successful return";
  315. break;
  316. case LIBERROR_OS:
  317. p = "Operating system error";
  318. break;
  319. case LIBERROR_BAD_OPTION:
  320. p = "Bad statement option";
  321. break;
  322. case LIBERROR_MISSING_OPTION:
  323. p = "Missing statement option";
  324. break;
  325. case LIBERROR_OPTION_CONFLICT:
  326. p = "Conflicting statement options";
  327. break;
  328. case LIBERROR_ALREADY_OPEN:
  329. p = "File already opened in another unit";
  330. break;
  331. case LIBERROR_BAD_UNIT:
  332. p = "Unattached unit";
  333. break;
  334. case LIBERROR_FORMAT:
  335. p = "FORMAT error";
  336. break;
  337. case LIBERROR_BAD_ACTION:
  338. p = "Incorrect ACTION specified";
  339. break;
  340. case LIBERROR_ENDFILE:
  341. p = "Read past ENDFILE record";
  342. break;
  343. case LIBERROR_BAD_US:
  344. p = "Corrupt unformatted sequential file";
  345. break;
  346. case LIBERROR_READ_VALUE:
  347. p = "Bad value during read";
  348. break;
  349. case LIBERROR_READ_OVERFLOW:
  350. p = "Numeric overflow on read";
  351. break;
  352. case LIBERROR_INTERNAL:
  353. p = "Internal error in run-time library";
  354. break;
  355. case LIBERROR_INTERNAL_UNIT:
  356. p = "Internal unit I/O error";
  357. break;
  358. case LIBERROR_DIRECT_EOR:
  359. p = "Write exceeds length of DIRECT access record";
  360. break;
  361. case LIBERROR_SHORT_RECORD:
  362. p = "I/O past end of record on unformatted file";
  363. break;
  364. case LIBERROR_CORRUPT_FILE:
  365. p = "Unformatted file structure has been corrupted";
  366. break;
  367. default:
  368. p = "Unknown error code";
  369. break;
  370. }
  371. return p;
  372. }
  373. /* generate_error()-- Come here when an error happens. This
  374. * subroutine is called if it is possible to continue on after the error.
  375. * If an IOSTAT or IOMSG variable exists, we set it. If IOSTAT or
  376. * ERR labels are present, we return, otherwise we terminate the program
  377. * after printing a message. The error code is always required but the
  378. * message parameter can be NULL, in which case a string describing
  379. * the most recent operating system error is used. */
  380. void
  381. generate_error (st_parameter_common *cmp, int family, const char *message)
  382. {
  383. char errmsg[STRERR_MAXSZ];
  384. /* If there was a previous error, don't mask it with another
  385. error message, EOF or EOR condition. */
  386. if ((cmp->flags & IOPARM_LIBRETURN_MASK) == IOPARM_LIBRETURN_ERROR)
  387. return;
  388. /* Set the error status. */
  389. if ((cmp->flags & IOPARM_HAS_IOSTAT))
  390. *cmp->iostat = (family == LIBERROR_OS) ? errno : family;
  391. if (message == NULL)
  392. message =
  393. (family == LIBERROR_OS) ? gf_strerror (errno, errmsg, STRERR_MAXSZ) :
  394. translate_error (family);
  395. if (cmp->flags & IOPARM_HAS_IOMSG)
  396. cf_strcpy (cmp->iomsg, cmp->iomsg_len, message);
  397. /* Report status back to the compiler. */
  398. cmp->flags &= ~IOPARM_LIBRETURN_MASK;
  399. switch (family)
  400. {
  401. case LIBERROR_EOR:
  402. cmp->flags |= IOPARM_LIBRETURN_EOR;
  403. if ((cmp->flags & IOPARM_EOR))
  404. return;
  405. break;
  406. case LIBERROR_END:
  407. cmp->flags |= IOPARM_LIBRETURN_END;
  408. if ((cmp->flags & IOPARM_END))
  409. return;
  410. break;
  411. default:
  412. cmp->flags |= IOPARM_LIBRETURN_ERROR;
  413. if ((cmp->flags & IOPARM_ERR))
  414. return;
  415. break;
  416. }
  417. /* Return if the user supplied an iostat variable. */
  418. if ((cmp->flags & IOPARM_HAS_IOSTAT))
  419. return;
  420. /* Terminate the program */
  421. recursion_check ();
  422. show_locus (cmp);
  423. estr_write ("Fortran runtime error: ");
  424. estr_write (message);
  425. estr_write ("\n");
  426. exit (2);
  427. }
  428. iexport(generate_error);
  429. /* generate_warning()-- Similar to generate_error but just give a warning. */
  430. void
  431. generate_warning (st_parameter_common *cmp, const char *message)
  432. {
  433. if (message == NULL)
  434. message = " ";
  435. show_locus (cmp);
  436. estr_write ("Fortran runtime warning: ");
  437. estr_write (message);
  438. estr_write ("\n");
  439. }
  440. /* Whether, for a feature included in a given standard set (GFC_STD_*),
  441. we should issue an error or a warning, or be quiet. */
  442. notification
  443. notification_std (int std)
  444. {
  445. int warning;
  446. if (!compile_options.pedantic)
  447. return NOTIFICATION_SILENT;
  448. warning = compile_options.warn_std & std;
  449. if ((compile_options.allow_std & std) != 0 && !warning)
  450. return NOTIFICATION_SILENT;
  451. return warning ? NOTIFICATION_WARNING : NOTIFICATION_ERROR;
  452. }
  453. /* Possibly issue a warning/error about use of a nonstandard (or deleted)
  454. feature. An error/warning will be issued if the currently selected
  455. standard does not contain the requested bits. */
  456. try
  457. notify_std (st_parameter_common *cmp, int std, const char * message)
  458. {
  459. int warning;
  460. if (!compile_options.pedantic)
  461. return SUCCESS;
  462. warning = compile_options.warn_std & std;
  463. if ((compile_options.allow_std & std) != 0 && !warning)
  464. return SUCCESS;
  465. if (!warning)
  466. {
  467. recursion_check ();
  468. show_locus (cmp);
  469. estr_write ("Fortran runtime error: ");
  470. estr_write (message);
  471. estr_write ("\n");
  472. exit (2);
  473. }
  474. else
  475. {
  476. show_locus (cmp);
  477. estr_write ("Fortran runtime warning: ");
  478. estr_write (message);
  479. estr_write ("\n");
  480. }
  481. return FAILURE;
  482. }