contrib/gcc-3.4/libf2c/f2cext.c

   1 /* Copyright (C) 1997 Free Software Foundation, Inc.
   2 This file is part of GNU Fortran run-time library.
   3
   4 This library is free software; you can redistribute it and/or modify it
   5 under the terms of the GNU Library General Public License as published
   6 by the Free Software Foundation; either version 2 of the License, or
   7 (at your option) any later version.
   8
   9 GNU Fortran is distributed in the hope that it will be useful,
  10 but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 Library General Public License for more details.
  13
  14 You should have received a copy of the GNU Library General Public
  15 License along with GNU Fortran; see the file COPYING.LIB.  If
  16 not, write to the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
  17 Boston, MA 02111-1307, USA.  */
  18
  19 #include <math.h>               /* for j0 et al */
  20 #include <f2c.h>
  21 typedef void *sig_proc; /* For now, this will have to do. */
  22
  23 #ifdef Labort
  24 int abort_ (void) {
  25     extern int G77_abort_0 (void);
  26     return G77_abort_0 ();
  27 }
  28 #endif
  29
  30 #ifdef Lderf
  31 double derf_ (doublereal *x) {
  32     extern double G77_derf_0 (doublereal *x);
  33     return G77_derf_0 (x);
  34 }
  35 #endif
  36
  37 #ifdef Lderfc
  38 double derfc_ (doublereal *x) {
  39     extern double G77_derfc_0 (doublereal *x);
  40     return G77_derfc_0 (x);
  41 }
  42 #endif
  43
  44 #ifdef Lef1asc
  45 int ef1asc_ (ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb) {
  46     extern int G77_ef1asc_0 (ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb);
  47     return G77_ef1asc_0 (a, la, b, lb);
  48 }
  49 #endif
  50
  51 #ifdef Lef1cmc
  52 integer ef1cmc_ (ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb) {
  53     extern integer G77_ef1cmc_0 (ftnint *a, ftnlen *la, ftnint *b, ftnlen *lb);
  54     return G77_ef1cmc_0 (a, la, b, lb);
  55 }
  56 #endif
  57
  58 #ifdef Lerf
  59 double erf_ (real *x) {
  60     extern double G77_erf_0 (real *x);
  61     return G77_erf_0 (x);
  62 }
  63 #endif
  64
  65 #ifdef Lerfc
  66 double erfc_ (real *x) {
  67     extern double G77_erfc_0 (real *x);
  68     return G77_erfc_0 (x);
  69 }
  70 #endif
  71
  72 #ifdef Lexit
  73 void exit_ (integer *rc) {
  74     extern void G77_exit_0 (integer *rc);
  75     G77_exit_0 (rc);
  76 }
  77 #endif
  78
  79 #ifdef Lgetarg
  80 void getarg_ (ftnint *n, char *s, ftnlen ls) {
  81     extern void G77_getarg_0 (ftnint *n, char *s, ftnlen ls);
  82     G77_getarg_0 (n, s, ls);
  83 }
  84 #endif
  85
  86 #ifdef Lgetenv
  87 void getenv_ (char *fname, char *value, ftnlen flen, ftnlen vlen) {
  88     extern void G77_getenv_0 (char *fname, char *value, ftnlen flen, ftnlen vlen);
  89     G77_getenv_0 (fname, value, flen, vlen);
  90 }
  91 #endif
  92
  93 #ifdef Liargc
  94 ftnint iargc_ (void) {
  95     extern ftnint G77_iargc_0 (void);
  96     return G77_iargc_0 ();
  97 }
  98 #endif
  99
 100 #ifdef Lsignal
 101 void *signal_ (integer *sigp, sig_proc proc) {
 102     extern void *G77_signal_0 (integer *sigp, sig_proc proc);
 103     return G77_signal_0 (sigp, proc);
 104 }
 105 #endif
 106
 107 #ifdef Lsystem
 108 integer system_ (char *s, ftnlen n) {
 109     extern integer G77_system_0 (char *s, ftnlen n);
 110     return G77_system_0 (s, n);
 111 }
 112 #endif
 113
 114 #ifdef Lflush
 115 int flush_ (void) {
 116     extern int G77_flush_0 (void);
 117     return G77_flush_0 ();
 118 }
 119 #endif
 120
 121 #ifdef Lftell
 122 integer ftell_ (integer *Unit) {
 123     extern integer G77_ftell_0 (integer *Unit);
 124     return G77_ftell_0 (Unit);
 125 }
 126 #endif
 127
 128 #ifdef Lfseek
 129 integer fseek_ (integer *Unit, integer *offset, integer *xwhence) {
 130     extern integer G77_fseek_0 (integer *Unit, integer *offset, integer *xwhence);
 131     return G77_fseek_0 (Unit, offset, xwhence);
 132 }
 133 #endif
 134
 135 #ifdef Laccess
 136 integer access_ (const char *name, const char *mode, ftnlen Lname, ftnlen Lmode) {
 137     extern integer G77_access_0 (const char *name, const char *mode, ftnlen Lname, ftnlen Lmode);
 138     return G77_access_0 (name, mode, Lname, Lmode);
 139 }
 140 #endif
 141
 142 #ifdef Lalarm
 143 integer alarm_ (integer *seconds, sig_proc proc,
 144                 integer *status __attribute__ ((__unused__))) {
 145     extern integer G77_alarm_0 (integer *seconds, sig_proc proc);
 146     return G77_alarm_0 (seconds, proc);
 147 }
 148 #endif
 149
 150 #ifdef Lbesj0
 151 double besj0_ (const real *x) {
 152     return j0 (*x);
 153 }
 154 #endif
 155
 156 #ifdef Lbesj1
 157 double besj1_ (const real *x) {
 158     return j1 (*x);
 159 }
 160 #endif
 161
 162 #ifdef Lbesjn
 163 double besjn_ (const integer *n, real *x) {
 164     return jn (*n, *x);
 165 }
 166 #endif
 167
 168 #ifdef Lbesy0
 169 double besy0_ (const real *x) {
 170     return y0 (*x);
 171 }
 172 #endif
 173
 174 #ifdef Lbesy1
 175 double besy1_ (const real *x) {
 176     return y1 (*x);
 177 }
 178 #endif
 179
 180 #ifdef Lbesyn
 181 double besyn_ (const integer *n, real *x) {
 182     return yn (*n, *x);
 183 }
 184 #endif
 185
 186 #ifdef Lchdir
 187 integer chdir_ (const char *name, const ftnlen Lname) {
 188     extern integer G77_chdir_0 (const char *name, const ftnlen Lname);
 189     return G77_chdir_0 (name, Lname);
 190 }
 191 #endif
 192
 193 #ifdef Lchmod
 194 integer chmod_ (const char *name, const char *mode, const ftnlen Lname, const ftnlen Lmode) {
 195     extern integer G77_chmod_0 (const char *name, const char *mode, const ftnlen Lname, const ftnlen Lmode);
 196     return G77_chmod_0 (name, mode, Lname, Lmode);
 197 }
 198 #endif
 199
 200 #ifdef Lctime
 201 void ctime_ (char *chtime, const ftnlen Lchtime, longint *xstime) {
 202     extern void G77_ctime_0 (char *chtime, const ftnlen Lchtime, longint *xstime);
 203     G77_ctime_0 (chtime, Lchtime, xstime);
 204 }
 205 #endif
 206
 207 #ifdef Ldate_y2kbuggy
 208 int date_ (char *buf, ftnlen buf_len) {
 209   /* Fail to link, so user sees attempt to invoke non-Y2K-compliant
 210      routine.  */
 211     extern int G77_date_y2kbuggy_0 (char *buf, ftnlen buf_len);
 212     return G77_date_y2kbuggy_0 (buf, buf_len);
 213 }
 214 #endif
 215
 216 #ifdef Ldate_y2kbug
 217 int date_y2kbug__ (char *buf, ftnlen buf_len) {
 218   /* If user wants to invoke the non-Y2K-compliant routine via
 219      an `EXTERNAL' interface, avoiding the warning via g77's
 220      `INTRINSIC' interface, force coding of "y2kbug" string in
 221      user's program.  */
 222     extern int G77_date_y2kbug_0 (char *buf, ftnlen buf_len);
 223     return G77_date_y2kbug_0 (buf, buf_len);
 224 }
 225 #endif
 226
 227 #ifdef Ldbesj0
 228 double dbesj0_ (const double *x) {
 229     return j0 (*x);
 230 }
 231 #endif
 232
 233 #ifdef Ldbesj1
 234 double dbesj1_ (const double *x) {
 235     return j1 (*x);
 236 }
 237 #endif
 238
 239 #ifdef Ldbesjn
 240 double dbesjn_ (const integer *n, double *x) {
 241     return jn (*n, *x);
 242 }
 243 #endif
 244
 245 #ifdef Ldbesy0
 246 double dbesy0_ (const double *x) {
 247     return y0 (*x);
 248 }
 249 #endif
 250
 251 #ifdef Ldbesy1
 252 double dbesy1_ (const double *x) {
 253     return y1 (*x);
 254 }
 255 #endif
 256
 257 #ifdef Ldbesyn
 258 double dbesyn_ (const integer *n, double *x) {
 259     return yn (*n, *x);
 260 }
 261 #endif
 262
 263 #ifdef Ldtime
 264 double dtime_ (real tarray[2]) {
 265     extern double G77_dtime_0 (real tarray[2]);
 266     return G77_dtime_0 (tarray);
 267 }
 268 #endif
 269
 270 #ifdef Letime
 271 double etime_ (real tarray[2]) {
 272     extern double G77_etime_0 (real tarray[2]);
 273     return G77_etime_0 (tarray);
 274 }
 275 #endif
 276
 277 #ifdef Lfdate
 278 void fdate_ (char *ret_val, ftnlen ret_val_len) {
 279     extern void G77_fdate_0 (char *ret_val, ftnlen ret_val_len);
 280     G77_fdate_0 (ret_val, ret_val_len);
 281 }
 282 #endif
 283
 284 #ifdef Lfgetc
 285 integer fgetc_ (const integer *lunit, char *c, ftnlen Lc) {
 286     extern integer G77_fgetc_0 (const integer *lunit, char *c, ftnlen Lc);
 287     return G77_fgetc_0 (lunit, c, Lc);
 288 }
 289 #endif
 290
 291 #ifdef Lfget
 292 integer fget_ (char *c, const ftnlen Lc) {
 293     extern integer G77_fget_0 (char *c, const ftnlen Lc);
 294     return G77_fget_0 (c, Lc);
 295 }
 296 #endif
 297
 298 #ifdef Lflush1
 299 int flush1_ (const integer *lunit) {
 300     extern int G77_flush1_0 (const integer *lunit);
 301     return G77_flush1_0 (lunit);
 302 }
 303 #endif
 304
 305 #ifdef Lfnum
 306 integer fnum_ (integer *lunit) {
 307     extern integer G77_fnum_0 (integer *lunit);
 308     return G77_fnum_0 (lunit);
 309 }
 310 #endif
 311
 312 #ifdef Lfputc
 313 integer fputc_ (const integer *lunit, const char *c, const ftnlen Lc) {
 314     extern integer G77_fputc_0 (const integer *lunit, const char *c, const ftnlen Lc);
 315     return G77_fputc_0 (lunit, c, Lc);
 316 }
 317 #endif
 318
 319 #ifdef Lfput
 320 integer fput_ (const char *c, const ftnlen Lc) {
 321     extern integer G77_fput_0 (const char *c, const ftnlen Lc);
 322     return G77_fput_0 (c, Lc);
 323 }
 324 #endif
 325
 326 #ifdef Lfstat
 327 integer fstat_ (const integer *lunit, integer statb[13]) {
 328     extern integer G77_fstat_0 (const integer *lunit, integer statb[13]);
 329     return G77_fstat_0 (lunit, statb);
 330 }
 331 #endif
 332
 333 #ifdef Lgerror
 334 int gerror_ (char *str, ftnlen Lstr) {
 335     extern int G77_gerror_0 (char *str, ftnlen Lstr);
 336     return G77_gerror_0 (str,  Lstr);
 337 }
 338 #endif
 339
 340 #ifdef Lgetcwd
 341 integer getcwd_ (char *str, const ftnlen Lstr) {
 342     extern integer G77_getcwd_0 (char *str, const ftnlen Lstr);
 343     return G77_getcwd_0 (str, Lstr);
 344 }
 345 #endif
 346
 347 #ifdef Lgetgid
 348 integer getgid_ (void) {
 349     extern integer G77_getgid_0 (void);
 350     return G77_getgid_0 ();
 351 }
 352 #endif
 353
 354 #ifdef Lgetlog
 355 int getlog_ (char *str, const ftnlen Lstr) {
 356     extern int G77_getlog_0 (char *str, const ftnlen Lstr);
 357     return G77_getlog_0 (str, Lstr);
 358 }
 359 #endif
 360
 361 #ifdef Lgetpid
 362 integer getpid_ (void) {
 363     extern integer G77_getpid_0 (void);
 364     return G77_getpid_0 ();
 365 }
 366 #endif
 367
 368 #ifdef Lgetuid
 369 integer getuid_ (void) {
 370     extern integer G77_getuid_0 (void);
 371     return G77_getuid_0 ();
 372 }
 373 #endif
 374
 375 #ifdef Lgmtime
 376 int gmtime_ (const integer *stime, integer tarray[9]) {
 377     extern int G77_gmtime_0 (const integer *stime, integer tarray[9]);
 378     return G77_gmtime_0 (stime, tarray);
 379 }
 380 #endif
 381
 382 #ifdef Lhostnm
 383 integer hostnm_ (char *name, ftnlen Lname) {
 384     extern integer G77_hostnm_0 (char *name, ftnlen Lname);
 385     return G77_hostnm_0 (name, Lname);
 386 }
 387 #endif
 388
 389 #ifdef Lidate
 390 int idate_ (int iarray[3]) {
 391     extern int G77_idate_0 (int iarray[3]);
 392     return G77_idate_0 (iarray);
 393 }
 394 #endif
 395
 396 #ifdef Lierrno
 397 integer ierrno_ (void) {
 398     extern integer G77_ierrno_0 (void);
 399     return G77_ierrno_0 ();
 400 }
 401 #endif
 402
 403 #ifdef Lirand
 404 integer irand_ (integer *flag) {
 405     extern integer G77_irand_0 (integer *flag);
 406     return G77_irand_0 (flag);
 407 }
 408 #endif
 409
 410 #ifdef Lisatty
 411 logical isatty_ (integer *lunit) {
 412     extern logical G77_isatty_0 (integer *lunit);
 413     return G77_isatty_0 (lunit);
 414 }
 415 #endif
 416
 417 #ifdef Litime
 418 int itime_ (integer tarray[3]) {
 419     extern int G77_itime_0 (integer tarray[3]);
 420     return G77_itime_0 (tarray);
 421 }
 422 #endif
 423
 424 #ifdef Lkill
 425 integer kill_ (const integer *pid, const integer *signum) {
 426     extern integer G77_kill_0 (const integer *pid, const integer *signum);
 427     return G77_kill_0 (pid, signum);
 428 }
 429 #endif
 430
 431 #ifdef Llink
 432 integer link_ (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2) {
 433     extern integer G77_link_0 (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2);
 434     return G77_link_0 (path1, path2, Lpath1, Lpath2);
 435 }
 436 #endif
 437
 438 #ifdef Llnblnk
 439 integer lnblnk_ (char *str, ftnlen str_len) {
 440     extern integer G77_lnblnk_0 (char *str, ftnlen str_len);
 441     return G77_lnblnk_0 (str, str_len);
 442 }
 443 #endif
 444
 445 #ifdef Llstat
 446 integer lstat_ (const char *name, integer statb[13], const ftnlen Lname) {
 447     extern integer G77_lstat_0 (const char *name, integer statb[13], const ftnlen Lname);
 448     return G77_lstat_0 (name, statb, Lname);
 449 }
 450 #endif
 451
 452 #ifdef Lltime
 453 int ltime_ (const integer *stime, integer tarray[9]) {
 454     extern int G77_ltime_0 (const integer *stime, integer tarray[9]);
 455     return G77_ltime_0 (stime, tarray);
 456 }
 457 #endif
 458
 459 #ifdef Lmclock
 460 longint mclock_ (void) {
 461     extern longint G77_mclock_0 (void);
 462     return G77_mclock_0 ();
 463 }
 464 #endif
 465
 466 #ifdef Lperror
 467 int perror_ (const char *str, const ftnlen Lstr) {
 468     extern int G77_perror_0 (const char *str, const ftnlen Lstr);
 469     return G77_perror_0 (str, Lstr);
 470 }
 471 #endif
 472
 473 #ifdef Lrand
 474 double rand_ (integer *flag) {
 475     extern double G77_rand_0 (integer *flag);
 476     return G77_rand_0 (flag);
 477 }
 478 #endif
 479
 480 #ifdef Lrename
 481 integer rename_ (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2) {
 482     extern integer G77_rename_0 (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2);
 483     return G77_rename_0 (path1, path2, Lpath1, Lpath2);
 484 }
 485 #endif
 486
 487 #ifdef Lsecnds
 488 double secnds_ (real *r) {
 489     extern double G77_secnds_0 (real *r);
 490     return G77_secnds_0 (r);
 491 }
 492 #endif
 493
 494 #ifdef Lsecond
 495 double second_ () {
 496     extern double G77_second_0 ();
 497     return G77_second_0 ();
 498 }
 499 #endif
 500
 501 #ifdef Lsleep
 502 int sleep_ (const integer *seconds) {
 503     extern int G77_sleep_0 (const integer *seconds);
 504     return G77_sleep_0 (seconds);
 505 }
 506 #endif
 507
 508 #ifdef Lsrand
 509 int srand_ (const integer *seed) {
 510     extern int G77_srand_0 (const integer *seed);
 511     return G77_srand_0 (seed);
 512 }
 513 #endif
 514
 515 #ifdef Lstat
 516 integer stat_ (const char *name, integer statb[13], const ftnlen Lname) {
 517     extern integer G77_stat_0 (const char *name, integer statb[13], const ftnlen Lname);
 518     return G77_stat_0 (name, statb, Lname);
 519 }
 520 #endif
 521
 522 #ifdef Lsymlnk
 523 integer symlnk_ (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2) {
 524     extern integer G77_symlnk_0 (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2);
 525     return G77_symlnk_0 (path1, path2, Lpath1, Lpath2);
 526 }
 527 #endif
 528
 529 #ifdef Ltime
 530 longint time_ (void) {
 531     extern longint G77_time_0 (void);
 532     return G77_time_0 ();
 533 }
 534 #endif
 535
 536 #ifdef Lttynam
 537 void ttynam_ (char *ret_val, ftnlen ret_val_len, integer *lunit) {
 538     extern void G77_ttynam_0 (char *ret_val, ftnlen ret_val_len, integer *lunit);
 539     G77_ttynam_0 (ret_val, ret_val_len, lunit);
 540 }
 541 #endif
 542
 543 #ifdef Lumask
 544 integer umask_ (integer *mask) {
 545     extern integer G77_umask_0 (integer *mask);
 546     return G77_umask_0 (mask);
 547 }
 548 #endif
 549
 550 #ifdef Lunlink
 551 integer unlink_ (const char *str, const ftnlen Lstr) {
 552     extern integer G77_unlink_0 (const char *str, const ftnlen Lstr);
 553     return G77_unlink_0 (str, Lstr);
 554 }
 555 #endif
 556
 557 #ifdef Lvxtidt_y2kbuggy
 558 int vxtidate_ (integer *m, integer *d, integer *y) {
 559   /* Fail to link, so user sees attempt to invoke non-Y2K-compliant
 560      routine.  */
 561     extern int G77_vxtidate_y2kbuggy_0 (integer *m, integer *d, integer *y);
 562     return G77_vxtidate_y2kbuggy_0 (m, d, y);
 563 }
 564 #endif
 565
 566 #ifdef Lvxtidt_y2kbug
 567 int vxtidate_y2kbug__ (integer *m, integer *d, integer *y) {
 568   /* If user wants to invoke the non-Y2K-compliant routine via
 569      an `EXTERNAL' interface, avoiding the warning via g77's
 570      `INTRINSIC' interface, force coding of "y2kbug" string in
 571      user's program.  */
 572     extern int G77_vxtidate_y2kbug_0 (integer *m, integer *d, integer *y);
 573     return G77_vxtidate_y2kbug_0 (m, d, y);
 574 }
 575 #endif
 576
 577 #ifdef Lvxttim
 578 void vxttime_ (char chtime[8], const ftnlen Lchtime) {
 579     extern void G77_vxttime_0 (char chtime[8], const ftnlen Lchtime);
 580     G77_vxttime_0 (chtime, Lchtime);
 581 }
 582 #endif