ghc/compiler/yaccParser/util.c

   1 /**********************************************************************
   2 *                                                                     *
   3 *                                                                     *
   4 *      Declarations                                                   *
   5 *                                                                     *
   6 *                                                                     *
   7 **********************************************************************/
   8
   9 #include "hspincl.h"
  10 #include "constants.h"
  11 #include "utils.h"
  12
  13 #ifndef DPH
  14 #define PARSER_VERSION "0.26"
  15 #else
  16 #define PARSER_VERSION "0.26 -- for Data Parallel Haskell"
  17 #endif
  18
  19 tree root;              /* The root of the built syntax tree. */
  20 list Lnil;
  21 list all;
  22
  23 BOOLEAN nonstandardFlag = FALSE;  /* Set if non-std Haskell extensions to be used. */
  24 BOOLEAN acceptPrim = FALSE;       /* Set if Int#, etc., may be used                */
  25 BOOLEAN haskell1_3Flag = FALSE;   /* Set if we are doing (proto?) Haskell 1.3      */
  26 BOOLEAN etags = FALSE;            /* Set if we're parsing only to produce tags.    */
  27 BOOLEAN hashIds = FALSE;          /* Set if Identifiers should be hashed.          */
  28
  29 BOOLEAN ignoreSCC = TRUE;         /* Set if we ignore/filter scc expressions.      */
  30 BOOLEAN warnSCC = FALSE;          /* Set if we warn about ignored scc expressions. */
  31
  32 BOOLEAN implicitPrelude = TRUE;   /* Set if we implicitly import the Prelude.      */
  33 BOOLEAN ignorePragmas = FALSE;    /* Set if we want to ignore pragmas              */
  34
  35 /* From time to time, the format of interface files may change.
  36
  37    So that we don't get gratuitous syntax errors or silently slurp in
  38    junk info, two things: (a) the compiler injects a "this is a
  39    version N interface":
  40
  41         {-# GHC_PRAGMA INTERFACE VERSION <n> #-}
  42
  43    (b) this parser has a "minimum acceptable version", below which it
  44    refuses to parse the pragmas (it just considers them as comments).
  45    It also has a "maximum acceptable version", above which...
  46
  47    The minimum is so a new parser won't try to grok overly-old
  48    interfaces; the maximum (usually the current version number when
  49    the parser was released) is so an old parser will not try to grok
  50    since-upgraded interfaces.
  51
  52    If an interface has no INTERFACE VERSION line, it is taken to be
  53    version 0.
  54 */
  55 int minAcceptablePragmaVersion = 5;  /* 0.26 or greater ONLY */
  56 int maxAcceptablePragmaVersion = 5;  /* 0.26+ */
  57 int thisIfacePragmaVersion = 0;
  58
  59 char    *input_file_dir;        /* The directory where the input file is.        */
  60
  61 char HiSuffix[64] = ".hi";              /* can be changed with -h flag */
  62 char PreludeHiSuffix[64] = ".hi";       /* can be changed with -g flag */
  63
  64 BOOLEAN ExplicitHiSuffixGiven = 0;
  65 static BOOLEAN verbose = FALSE;         /* Set for verbose messages. */
  66
  67 /**********************************************************************
  68 *                                                                     *
  69 *                                                                     *
  70 *     Utility Functions                                               *
  71 *                                                                     *
  72 *                                                                     *
  73 **********************************************************************/
  74
  75 # include <stdio.h>
  76 # include "constants.h"
  77 # include "hspincl.h"
  78 # include "utils.h"
  79
  80 void
  81 process_args(argc,argv)
  82   int argc;
  83   char **argv;
  84 {
  85     BOOLEAN keep_munging_option = FALSE;
  86
  87 /*OLD: progname = argv[0]; */
  88     imports_dirlist     = mklnil();
  89     sys_imports_dirlist = mklnil();
  90
  91     argc--, argv++;
  92
  93     while (argc && argv[0][0] == '-') {
  94
  95         keep_munging_option = TRUE;
  96
  97         while (keep_munging_option && *++*argv != '\0') {
  98             switch(**argv) {
  99
 100             /* -I dir */
 101             case 'I':
 102                     imports_dirlist = lapp(imports_dirlist,*argv+1);
 103                     keep_munging_option = FALSE;
 104                     break;
 105
 106             /* -J dir (for system imports) */
 107             case 'J':
 108                     sys_imports_dirlist = lapp(sys_imports_dirlist,*argv+1);
 109                     keep_munging_option = FALSE;
 110                     break;
 111
 112             case 'g':
 113                     strcpy(PreludeHiSuffix, *argv+1);
 114                     keep_munging_option = FALSE;
 115                     break;
 116
 117             case 'h':
 118                     strcpy(HiSuffix, *argv+1);
 119                     ExplicitHiSuffixGiven = 1;
 120                     keep_munging_option = FALSE;
 121                     break;
 122
 123             case 'v':
 124                     who_am_i(); /* identify myself */
 125                     verbose = TRUE;
 126                     break;
 127
 128             case 'N':
 129                     nonstandardFlag = TRUE;
 130                     acceptPrim = TRUE;
 131                     break;
 132
 133             case '3':
 134                     haskell1_3Flag = TRUE;
 135                     break;
 136
 137             case 'S':
 138                     ignoreSCC = FALSE;
 139                     break;
 140
 141             case 'W':
 142                     warnSCC = TRUE;
 143                     break;
 144
 145             case 'p':
 146                     ignorePragmas = TRUE;
 147                     break;
 148
 149             case 'P':
 150                     implicitPrelude = FALSE;
 151                     break;
 152
 153             case 'D':
 154 #ifdef HSP_DEBUG
 155                     { extern int yydebug;
 156                       yydebug = 1;
 157                     }
 158 #endif
 159                     break;
 160
 161             /* -Hn -- Use Hash Table, Size n (if given) */
 162             case 'H':
 163                     hashIds = TRUE;
 164                     if(*(*argv+1)!= '\0')
 165                       hash_table_size = atoi(*argv+1);
 166                     break;
 167             case 'E':
 168                     etags = TRUE;
 169                     break;
 170             }
 171         }
 172         argc--, argv++;
 173     }
 174
 175     if(argc >= 1 && freopen(argv[0], "r", stdin) == NULL) {
 176             fprintf(stderr, "Cannot open %s.\n", argv[0]);
 177             exit(1);
 178     }
 179
 180     if(argc >= 2 && freopen(argv[1], "w", stdout) == NULL) {
 181             fprintf(stderr, "Cannot open %s.\n", argv[1]);
 182             exit(1);
 183     }
 184
 185
 186     /* By default, imports come from the directory of the source file */
 187     if ( argc >= 1 )
 188       {
 189         char *endchar;
 190
 191         input_file_dir = xmalloc (strlen(argv[0]) + 1);
 192         strcpy(input_file_dir, argv[0]);
 193 #ifdef macintosh
 194         endchar = rindex(input_file_dir, (int) ':');
 195 #else
 196         endchar = rindex(input_file_dir, (int) '/');
 197 #endif /* ! macintosh */
 198
 199         if ( endchar == NULL )
 200           {
 201             free(input_file_dir);
 202             input_file_dir = ".";
 203           }
 204         else
 205           *endchar = '\0';
 206       }
 207
 208     /* No input file -- imports come from the current directory first */
 209     else
 210       input_file_dir = ".";
 211
 212     imports_dirlist = mklcons( input_file_dir, imports_dirlist );
 213
 214     if (verbose)
 215       {
 216         fprintf(stderr,"Hash Table Contains %d entries\n",hash_table_size);
 217         if(acceptPrim)
 218           fprintf(stderr,"Allowing special syntax for Unboxed Values\n");
 219       }
 220 }
 221
 222 void
 223 error(s)
 224   char *s;
 225 {
 226 /*OLD:  fprintf(stderr, "%s: Error %s\n", progname, s); */
 227         fprintf(stderr, "PARSER: Error %s\n", s);
 228         exit(1);
 229 }
 230
 231 void
 232 who_am_i()
 233 {
 234   fprintf(stderr,"Glasgow Haskell parser, version %s\n", PARSER_VERSION);
 235 }
 236
 237 tree
 238 mkbinop(s, l, r)
 239   char *s;
 240   tree l, r;
 241 {
 242         return mkap(mkap(mkident(s), l), r);
 243 }
 244
 245 list
 246 lconc(l1, l2)
 247   list l1;
 248   list l2;
 249 {
 250         list t;
 251
 252         if (tlist(l1) == lnil)
 253                 return(l2);
 254         for(t = l1; tlist(ltl(t)) != lnil; t = ltl(t))
 255                 ;
 256         ltl(t) = l2;
 257         return(l1);
 258 }
 259
 260 list
 261 lapp(l1, l2)
 262   list l1;
 263   VOID_STAR l2;
 264 {
 265         list t;
 266
 267         if (tlist(l1) == lnil)
 268                 return(mklcons(l2, mklnil()));
 269         for(t = l1; tlist(ltl(t)) != lnil; t = ltl(t))
 270                 ;
 271         ltl(t) = mklcons(l2, mklnil());
 272         return(l1);
 273 }
 274
 275
 276 /************** Haskell Infix ops, built on mkap ******************/
 277
 278 tree mkinfixop(s, l, r)
 279   char *s;
 280   tree l, r;
 281 {
 282   tree ap = mkap(mkap(mkident(s), l), r);
 283   ap -> tag = tinfixop;
 284   return ap;
 285 }
 286
 287 tree *
 288 Rginfun(t)
 289  struct Sap *t;
 290 {
 291         if(t -> tag != tinfixop)
 292                 fprintf(stderr, "ginfun: illegal selection; was %d\n", t -> tag);
 293         return(Rgfun((struct Sap *) (t -> Xgfun)));
 294 }
 295
 296 tree *
 297 Rginarg1(t)
 298  struct Sap *t;
 299 {
 300         if(t -> tag != tinfixop)
 301                 fprintf(stderr, "ginarg1: illegal selection; was %d\n", t -> tag);
 302         return(Rgarg((struct Sap *) (t -> Xgfun)));
 303 }
 304
 305 tree *
 306 Rginarg2(t)
 307  struct Sap *t;
 308 {
 309         if(t -> tag != tinfixop)
 310                 fprintf(stderr, "ginarg2: illegal selection; was %d\n", t -> tag);
 311         return(& t -> Xgarg);
 312 }