contrib/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, integer *status) {
 144     extern integer G77_alarm_0 (integer *seconds, sig_proc proc);
 145     return G77_alarm_0 (seconds, proc);
 146 }
 147 #endif
 148
 149 #ifdef Lbesj0
 150 double besj0_ (const real *x) {
 151     return j0 (*x);
 152 }
 153 #endif
 154
 155 #ifdef Lbesj1
 156 double besj1_ (const real *x) {
 157     return j1 (*x);
 158 }
 159 #endif
 160
 161 #ifdef Lbesjn
 162 double besjn_ (const integer *n, real *x) {
 163     return jn (*n, *x);
 164 }
 165 #endif
 166
 167 #ifdef Lbesy0
 168 double besy0_ (const real *x) {
 169     return y0 (*x);
 170 }
 171 #endif
 172
 173 #ifdef Lbesy1
 174 double besy1_ (const real *x) {
 175     return y1 (*x);
 176 }
 177 #endif
 178
 179 #ifdef Lbesyn
 180 double besyn_ (const integer *n, real *x) {
 181     return yn (*n, *x);
 182 }
 183 #endif
 184
 185 #ifdef Lchdir
 186 integer chdir_ (const char *name, const ftnlen Lname) {
 187     extern integer G77_chdir_0 (const char *name, const ftnlen Lname);
 188     return G77_chdir_0 (name, Lname);
 189 }
 190 #endif
 191
 192 #ifdef Lchmod
 193 integer chmod_ (const char *name, const char *mode, const ftnlen Lname, const ftnlen Lmode) {
 194     extern integer G77_chmod_0 (const char *name, const char *mode, const ftnlen Lname, const ftnlen Lmode);
 195     return G77_chmod_0 (name, mode, Lname, Lmode);
 196 }
 197 #endif
 198
 199 #ifdef Lctime
 200 void ctime_ (char *chtime, const ftnlen Lchtime, longint *xstime) {
 201     extern void G77_ctime_0 (char *chtime, const ftnlen Lchtime, longint *xstime);
 202     G77_ctime_0 (chtime, Lchtime, xstime);
 203 }
 204 #endif
 205
 206 #ifdef Ldate_y2kbuggy
 207 int date_ (char *buf, ftnlen buf_len) {
 208   /* Fail to link, so user sees attempt to invoke non-Y2K-compliant
 209      routine.  */
 210     extern int G77_date_y2kbuggy_0 (char *buf, ftnlen buf_len);
 211     return G77_date_y2kbuggy_0 (buf, buf_len);
 212 }
 213 #endif
 214
 215 #ifdef Ldate_y2kbug
 216 int date_y2kbug__ (char *buf, ftnlen buf_len) {
 217   /* If user wants to invoke the non-Y2K-compliant routine via
 218      an `EXTERNAL' interface, avoiding the warning via g77's
 219      `INTRINSIC' interface, force coding of "y2kbug" string in
 220      user's program.  */
 221     extern int G77_date_y2kbug_0 (char *buf, ftnlen buf_len);
 222     return G77_date_y2kbug_0 (buf, buf_len);
 223 }
 224 #endif
 225
 226 #ifdef Ldbesj0
 227 double dbesj0_ (const double *x) {
 228     return j0 (*x);
 229 }
 230 #endif
 231
 232 #ifdef Ldbesj1
 233 double dbesj1_ (const double *x) {
 234     return j1 (*x);
 235 }
 236 #endif
 237
 238 #ifdef Ldbesjn
 239 double dbesjn_ (const integer *n, double *x) {
 240     return jn (*n, *x);
 241 }
 242 #endif
 243
 244 #ifdef Ldbesy0
 245 double dbesy0_ (const double *x) {
 246     return y0 (*x);
 247 }
 248 #endif
 249
 250 #ifdef Ldbesy1
 251 double dbesy1_ (const double *x) {
 252     return y1 (*x);
 253 }
 254 #endif
 255
 256 #ifdef Ldbesyn
 257 double dbesyn_ (const integer *n, double *x) {
 258     return yn (*n, *x);
 259 }
 260 #endif
 261
 262 #ifdef Ldtime
 263 double dtime_ (real tarray[2]) {
 264     extern double G77_dtime_0 (real tarray[2]);
 265     return G77_dtime_0 (tarray);
 266 }
 267 #endif
 268
 269 #ifdef Letime
 270 double etime_ (real tarray[2]) {
 271     extern double G77_etime_0 (real tarray[2]);
 272     return G77_etime_0 (tarray);
 273 }
 274 #endif
 275
 276 #ifdef Lfdate
 277 void fdate_ (char *ret_val, ftnlen ret_val_len) {
 278     extern void G77_fdate_0 (char *ret_val, ftnlen ret_val_len);
 279     G77_fdate_0 (ret_val, ret_val_len);
 280 }
 281 #endif
 282
 283 #ifdef Lfgetc
 284 integer fgetc_ (const integer *lunit, char *c, ftnlen Lc) {
 285     extern integer G77_fgetc_0 (const integer *lunit, char *c, ftnlen Lc);
 286     return G77_fgetc_0 (lunit, c, Lc);
 287 }
 288 #endif
 289
 290 #ifdef Lfget
 291 integer fget_ (char *c, const ftnlen Lc) {
 292     extern integer G77_fget_0 (char *c, const ftnlen Lc);
 293     return G77_fget_0 (c, Lc);
 294 }
 295 #endif
 296
 297 #ifdef Lflush1
 298 int flush1_ (const integer *lunit) {
 299     extern int G77_flush1_0 (const integer *lunit);
 300     return G77_flush1_0 (lunit);
 301 }
 302 #endif
 303
 304 #ifdef Lfnum
 305 integer fnum_ (integer *lunit) {
 306     extern integer G77_fnum_0 (integer *lunit);
 307     return G77_fnum_0 (lunit);
 308 }
 309 #endif
 310
 311 #ifdef Lfputc
 312 integer fputc_ (const integer *lunit, const char *c, const ftnlen Lc) {
 313     extern integer G77_fputc_0 (const integer *lunit, const char *c, const ftnlen Lc);
 314     return G77_fputc_0 (lunit, c, Lc);
 315 }
 316 #endif
 317
 318 #ifdef Lfput
 319 integer fput_ (const char *c, const ftnlen Lc) {
 320     extern integer G77_fput_0 (const char *c, const ftnlen Lc);
 321     return G77_fput_0 (c, Lc);
 322 }
 323 #endif
 324
 325 #ifdef Lfstat
 326 integer fstat_ (const integer *lunit, integer statb[13]) {
 327     extern integer G77_fstat_0 (const integer *lunit, integer statb[13]);
 328     return G77_fstat_0 (lunit, statb);
 329 }
 330 #endif
 331
 332 #ifdef Lgerror
 333 int gerror_ (char *str, ftnlen Lstr) {
 334     extern int G77_gerror_0 (char *str, ftnlen Lstr);
 335     return G77_gerror_0 (str,  Lstr);
 336 }
 337 #endif
 338
 339 #ifdef Lgetcwd
 340 integer getcwd_ (char *str, const ftnlen Lstr) {
 341     extern integer G77_getcwd_0 (char *str, const ftnlen Lstr);
 342     return G77_getcwd_0 (str, Lstr);
 343 }
 344 #endif
 345
 346 #ifdef Lgetgid
 347 integer getgid_ (void) {
 348     extern integer G77_getgid_0 (void);
 349     return G77_getgid_0 ();
 350 }
 351 #endif
 352
 353 #ifdef Lgetlog
 354 int getlog_ (char *str, const ftnlen Lstr) {
 355     extern int G77_getlog_0 (char *str, const ftnlen Lstr);
 356     return G77_getlog_0 (str, Lstr);
 357 }
 358 #endif
 359
 360 #ifdef Lgetpid
 361 integer getpid_ (void) {
 362     extern integer G77_getpid_0 (void);
 363     return G77_getpid_0 ();
 364 }
 365 #endif
 366
 367 #ifdef Lgetuid
 368 integer getuid_ (void) {
 369     extern integer G77_getuid_0 (void);
 370     return G77_getuid_0 ();
 371 }
 372 #endif
 373
 374 #ifdef Lgmtime
 375 int gmtime_ (const integer *stime, integer tarray[9]) {
 376     extern int G77_gmtime_0 (const integer *stime, integer tarray[9]);
 377     return G77_gmtime_0 (stime, tarray);
 378 }
 379 #endif
 380
 381 #ifdef Lhostnm
 382 integer hostnm_ (char *name, ftnlen Lname) {
 383     extern integer G77_hostnm_0 (char *name, ftnlen Lname);
 384     return G77_hostnm_0 (name, Lname);
 385 }
 386 #endif
 387
 388 #ifdef Lidate
 389 int idate_ (int iarray[3]) {
 390     extern int G77_idate_0 (int iarray[3]);
 391     return G77_idate_0 (iarray);
 392 }
 393 #endif
 394
 395 #ifdef Lierrno
 396 integer ierrno_ (void) {
 397     extern integer G77_ierrno_0 (void);
 398     return G77_ierrno_0 ();
 399 }
 400 #endif
 401
 402 #ifdef Lirand
 403 integer irand_ (integer *flag) {
 404     extern integer G77_irand_0 (integer *flag);
 405     return G77_irand_0 (flag);
 406 }
 407 #endif
 408
 409 #ifdef Lisatty
 410 logical isatty_ (integer *lunit) {
 411     extern logical G77_isatty_0 (integer *lunit);
 412     return G77_isatty_0 (lunit);
 413 }
 414 #endif
 415
 416 #ifdef Litime
 417 int itime_ (integer tarray[3]) {
 418     extern int G77_itime_0 (integer tarray[3]);
 419     return G77_itime_0 (tarray);
 420 }
 421 #endif
 422
 423 #ifdef Lkill
 424 integer kill_ (const integer *pid, const integer *signum) {
 425     extern integer G77_kill_0 (const integer *pid, const integer *signum);
 426     return G77_kill_0 (pid, signum);
 427 }
 428 #endif
 429
 430 #ifdef Llink
 431 integer link_ (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2) {
 432     extern integer G77_link_0 (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2);
 433     return G77_link_0 (path1, path2, Lpath1, Lpath2);
 434 }
 435 #endif
 436
 437 #ifdef Llnblnk
 438 integer lnblnk_ (char *str, ftnlen str_len) {
 439     extern integer G77_lnblnk_0 (char *str, ftnlen str_len);
 440     return G77_lnblnk_0 (str, str_len);
 441 }
 442 #endif
 443
 444 #ifdef Llstat
 445 integer lstat_ (const char *name, integer statb[13], const ftnlen Lname) {
 446     extern integer G77_lstat_0 (const char *name, integer statb[13], const ftnlen Lname);
 447     return G77_lstat_0 (name, statb, Lname);
 448 }
 449 #endif
 450
 451 #ifdef Lltime
 452 int ltime_ (const integer *stime, integer tarray[9]) {
 453     extern int G77_ltime_0 (const integer *stime, integer tarray[9]);
 454     return G77_ltime_0 (stime, tarray);
 455 }
 456 #endif
 457
 458 #ifdef Lmclock
 459 longint mclock_ (void) {
 460     extern longint G77_mclock_0 (void);
 461     return G77_mclock_0 ();
 462 }
 463 #endif
 464
 465 #ifdef Lperror
 466 int perror_ (const char *str, const ftnlen Lstr) {
 467     extern int G77_perror_0 (const char *str, const ftnlen Lstr);
 468     return G77_perror_0 (str, Lstr);
 469 }
 470 #endif
 471
 472 #ifdef Lrand
 473 double rand_ (integer *flag) {
 474     extern double G77_rand_0 (integer *flag);
 475     return G77_rand_0 (flag);
 476 }
 477 #endif
 478
 479 #ifdef Lrename
 480 integer rename_ (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2) {
 481     extern integer G77_rename_0 (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2);
 482     return G77_rename_0 (path1, path2, Lpath1, Lpath2);
 483 }
 484 #endif
 485
 486 #ifdef Lsecnds
 487 double secnds_ (real *r) {
 488     extern double G77_secnds_0 (real *r);
 489     return G77_secnds_0 (r);
 490 }
 491 #endif
 492
 493 #ifdef Lsecond
 494 double second_ () {
 495     extern double G77_second_0 ();
 496     return G77_second_0 ();
 497 }
 498 #endif
 499
 500 #ifdef Lsleep
 501 int sleep_ (const integer *seconds) {
 502     extern int G77_sleep_0 (const integer *seconds);
 503     return G77_sleep_0 (seconds);
 504 }
 505 #endif
 506
 507 #ifdef Lsrand
 508 int srand_ (const integer *seed) {
 509     extern int G77_srand_0 (const integer *seed);
 510     return G77_srand_0 (seed);
 511 }
 512 #endif
 513
 514 #ifdef Lstat
 515 integer stat_ (const char *name, integer statb[13], const ftnlen Lname) {
 516     extern integer G77_stat_0 (const char *name, integer statb[13], const ftnlen Lname);
 517     return G77_stat_0 (name, statb, Lname);
 518 }
 519 #endif
 520
 521 #ifdef Lsymlnk
 522 integer symlnk_ (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2) {
 523     extern integer G77_symlnk_0 (const char *path1, const char *path2, const ftnlen Lpath1, const ftnlen Lpath2);
 524     return G77_symlnk_0 (path1, path2, Lpath1, Lpath2);
 525 }
 526 #endif
 527
 528 #ifdef Ltime
 529 longint time_ (void) {
 530     extern longint G77_time_0 (void);
 531     return G77_time_0 ();
 532 }
 533 #endif
 534
 535 #ifdef Lttynam
 536 void ttynam_ (char *ret_val, ftnlen ret_val_len, integer *lunit) {
 537     extern void G77_ttynam_0 (char *ret_val, ftnlen ret_val_len, integer *lunit);
 538     G77_ttynam_0 (ret_val, ret_val_len, lunit);
 539 }
 540 #endif
 541
 542 #ifdef Lumask
 543 integer umask_ (integer *mask) {
 544     extern integer G77_umask_0 (integer *mask);
 545     return G77_umask_0 (mask);
 546 }
 547 #endif
 548
 549 #ifdef Lunlink
 550 integer unlink_ (const char *str, const ftnlen Lstr) {
 551     extern integer G77_unlink_0 (const char *str, const ftnlen Lstr);
 552     return G77_unlink_0 (str, Lstr);
 553 }
 554 #endif
 555
 556 #ifdef Lvxtidt_y2kbuggy
 557 int vxtidate_ (integer *m, integer *d, integer *y) {
 558   /* Fail to link, so user sees attempt to invoke non-Y2K-compliant
 559      routine.  */
 560     extern int G77_vxtidate_y2kbuggy_0 (integer *m, integer *d, integer *y);
 561     return G77_vxtidate_y2kbuggy_0 (m, d, y);
 562 }
 563 #endif
 564
 565 #ifdef Lvxtidt_y2kbug
 566 int vxtidate_y2kbug__ (integer *m, integer *d, integer *y) {
 567   /* If user wants to invoke the non-Y2K-compliant routine via
 568      an `EXTERNAL' interface, avoiding the warning via g77's
 569      `INTRINSIC' interface, force coding of "y2kbug" string in
 570      user's program.  */
 571     extern int G77_vxtidate_y2kbug_0 (integer *m, integer *d, integer *y);
 572     return G77_vxtidate_y2kbug_0 (m, d, y);
 573 }
 574 #endif
 575
 576 #ifdef Lvxttim
 577 void vxttime_ (char chtime[8], const ftnlen Lchtime) {
 578     extern void G77_vxttime_0 (char chtime[8], const ftnlen Lchtime);
 579     G77_vxttime_0 (chtime, Lchtime);
 580 }
 581 #endif