l4/pkg/libgfortran/lib/contrib/intrinsics/args.c

   1 /* Implementation of the GETARG and IARGC g77, and
   2    corresponding F2003, intrinsics.
   3    Copyright (C) 2004-2015 Free Software Foundation, Inc.
   4    Contributed by Bud Davis and Janne Blomqvist.
   5
   6 This file is part of the GNU Fortran 95 runtime library (libgfortran).
   7
   8 Libgfortran is free software; you can redistribute it and/or
   9 modify it under the terms of the GNU General Public
  10 License as published by the Free Software Foundation; either
  11 version 3 of the License, or (at your option) any later version.
  12
  13 Libgfortran is distributed in the hope that it will be useful,
  14 but WITHOUT ANY WARRANTY; without even the implied warranty of
  15 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16 GNU General Public License for more details.
  17
  18 Under Section 7 of GPL version 3, you are granted additional
  19 permissions described in the GCC Runtime Library Exception, version
  20 3.1, as published by the Free Software Foundation.
  21
  22 You should have received a copy of the GNU General Public License and
  23 a copy of the GCC Runtime Library Exception along with this program;
  24 see the files COPYING3 and COPYING.RUNTIME respectively.  If not, see
  25 <http://www.gnu.org/licenses/>.  */
  26
  27 #include "libgfortran.h"
  28 #include <string.h>
  29
  30
  31 /* Get a commandline argument.  */
  32
  33 extern void getarg_i4 (GFC_INTEGER_4 *, char *, gfc_charlen_type);
  34 iexport_proto(getarg_i4);
  35
  36 void
  37 getarg_i4 (GFC_INTEGER_4 *pos, char  *val, gfc_charlen_type val_len)
  38 {
  39   int argc;
  40   int arglen;
  41   char **argv;
  42
  43   get_args (&argc, &argv);
  44
  45   if (val_len < 1 || !val )
  46     return;   /* something is wrong , leave immediately */
  47
  48   memset (val, ' ', val_len);
  49
  50   if ((*pos) + 1 <= argc  && *pos >=0 )
  51     {
  52       arglen = strlen (argv[*pos]);
  53       if (arglen > val_len)
  54         arglen = val_len;
  55       memcpy (val, argv[*pos], arglen);
  56     }
  57 }
  58 iexport(getarg_i4);
  59
  60
  61 /* INTEGER*8 wrapper of getarg.  */
  62
  63 extern void getarg_i8 (GFC_INTEGER_8 *, char *, gfc_charlen_type);
  64 export_proto (getarg_i8);
  65
  66 void
  67 getarg_i8 (GFC_INTEGER_8 *pos, char  *val, gfc_charlen_type val_len)
  68 {
  69   GFC_INTEGER_4 pos4 = (GFC_INTEGER_4) *pos;
  70   getarg_i4 (&pos4, val, val_len);
  71 }
  72
  73
  74 /* Return the number of commandline arguments.  The g77 info page
  75    states that iargc does not include the specification of the
  76    program name itself.  */
  77
  78 extern GFC_INTEGER_4 iargc (void);
  79 export_proto(iargc);
  80
  81 GFC_INTEGER_4
  82 iargc (void)
  83 {
  84   int argc;
  85   char **argv;
  86
  87   get_args (&argc, &argv);
  88
  89   return (argc - 1);
  90 }
  91
  92
  93 /* F2003 intrinsic functions and subroutines related to command line
  94    arguments.
  95
  96    - function command_argument_count() is converted to iargc by the compiler.
  97
  98    - subroutine get_command([command, length, status]).
  99
 100    - subroutine get_command_argument(number, [value, length, status]).
 101 */
 102
 103 /* These two status codes are specified in the standard. */
 104 #define GFC_GC_SUCCESS 0
 105 #define GFC_GC_VALUE_TOO_SHORT -1
 106
 107 /* Processor-specific status failure code. */
 108 #define GFC_GC_FAILURE 42
 109
 110
 111 extern void get_command_argument_i4 (GFC_INTEGER_4 *, char *, GFC_INTEGER_4 *,
 112                                      GFC_INTEGER_4 *, gfc_charlen_type);
 113 iexport_proto(get_command_argument_i4);
 114
 115 /* Get a single commandline argument.  */
 116
 117 void
 118 get_command_argument_i4 (GFC_INTEGER_4 *number, char *value,
 119                          GFC_INTEGER_4 *length, GFC_INTEGER_4 *status,
 120                          gfc_charlen_type value_len)
 121 {
 122   int argc, arglen = 0, stat_flag = GFC_GC_SUCCESS;
 123   char **argv;
 124
 125   if (number == NULL )
 126     /* Should never happen.  */
 127     runtime_error ("Missing argument to get_command_argument");
 128
 129   if (value == NULL && length == NULL && status == NULL)
 130     return; /* No need to do anything.  */
 131
 132   get_args (&argc, &argv);
 133
 134   if (*number < 0 || *number >= argc)
 135     stat_flag = GFC_GC_FAILURE;
 136   else
 137     arglen = strlen(argv[*number]);
 138
 139   if (value != NULL)
 140     {
 141       if (value_len < 1)
 142         stat_flag = GFC_GC_FAILURE;
 143       else
 144         memset (value, ' ', value_len);
 145     }
 146
 147   if (value != NULL && stat_flag != GFC_GC_FAILURE)
 148     {
 149       if (arglen > value_len)
 150          stat_flag = GFC_GC_VALUE_TOO_SHORT;
 151
 152       memcpy (value, argv[*number], arglen <= value_len ? arglen : value_len);
 153     }
 154
 155   if (length != NULL)
 156     *length = arglen;
 157
 158   if (status != NULL)
 159     *status = stat_flag;
 160 }
 161 iexport(get_command_argument_i4);
 162
 163
 164 /* INTEGER*8 wrapper for get_command_argument.  */
 165
 166 extern void get_command_argument_i8 (GFC_INTEGER_8 *, char *, GFC_INTEGER_8 *,
 167                                      GFC_INTEGER_8 *, gfc_charlen_type);
 168 export_proto(get_command_argument_i8);
 169
 170 void
 171 get_command_argument_i8 (GFC_INTEGER_8 *number, char *value,
 172                          GFC_INTEGER_8 *length, GFC_INTEGER_8 *status,
 173                          gfc_charlen_type value_len)
 174 {
 175   GFC_INTEGER_4 number4;
 176   GFC_INTEGER_4 length4;
 177   GFC_INTEGER_4 status4;
 178
 179   number4 = (GFC_INTEGER_4) *number;
 180   get_command_argument_i4 (&number4, value, &length4, &status4, value_len);
 181   if (length)
 182     *length = length4;
 183   if (status)
 184     *status = status4;
 185 }
 186
 187
 188 /* Return the whole commandline.  */
 189
 190 extern void get_command_i4 (char *, GFC_INTEGER_4 *, GFC_INTEGER_4 *,
 191                             gfc_charlen_type);
 192 iexport_proto(get_command_i4);
 193
 194 void
 195 get_command_i4 (char *command, GFC_INTEGER_4 *length, GFC_INTEGER_4 *status,
 196                 gfc_charlen_type command_len)
 197 {
 198   int i, argc, arglen, thisarg;
 199   int stat_flag = GFC_GC_SUCCESS;
 200   int tot_len = 0;
 201   char **argv;
 202
 203   if (command == NULL && length == NULL && status == NULL)
 204     return; /* No need to do anything.  */
 205
 206   get_args (&argc, &argv);
 207
 208   if (command != NULL)
 209     {
 210       /* Initialize the string to blanks.  */
 211       if (command_len < 1)
 212         stat_flag = GFC_GC_FAILURE;
 213       else
 214         memset (command, ' ', command_len);
 215     }
 216
 217   for (i = 0; i < argc ; i++)
 218     {
 219       arglen = strlen(argv[i]);
 220
 221       if (command != NULL && stat_flag == GFC_GC_SUCCESS)
 222         {
 223           thisarg = arglen;
 224           if (tot_len + thisarg > command_len)
 225             {
 226               thisarg = command_len - tot_len; /* Truncate.  */
 227               stat_flag = GFC_GC_VALUE_TOO_SHORT;
 228             }
 229           /* Also a space before the next arg.  */
 230           else if (i != argc - 1 && tot_len + arglen == command_len)
 231             stat_flag = GFC_GC_VALUE_TOO_SHORT;
 232
 233           memcpy (&command[tot_len], argv[i], thisarg);
 234         }
 235
 236       /* Add the legth of the argument.  */
 237       tot_len += arglen;
 238       if (i != argc - 1)
 239         tot_len++;
 240     }
 241
 242   if (length != NULL)
 243     *length = tot_len;
 244
 245   if (status != NULL)
 246     *status = stat_flag;
 247 }
 248 iexport(get_command_i4);
 249
 250
 251 /* INTEGER*8 wrapper for get_command.  */
 252
 253 extern void get_command_i8 (char *, GFC_INTEGER_8 *, GFC_INTEGER_8 *,
 254                             gfc_charlen_type);
 255 export_proto(get_command_i8);
 256
 257 void
 258 get_command_i8 (char *command, GFC_INTEGER_8 *length, GFC_INTEGER_8 *status,
 259                 gfc_charlen_type command_len)
 260 {
 261   GFC_INTEGER_4 length4;
 262   GFC_INTEGER_4 status4;
 263
 264   get_command_i4 (command, &length4, &status4, command_len);
 265   if (length)
 266     *length = length4;
 267   if (status)
 268     *status = status4;
 269 }