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 static 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 /* OLD 95/08: BOOLEAN ExplicitHiSuffixGiven = 0; */
  65 static BOOLEAN verbose = FALSE;         /* Set for verbose messages. */
  66
  67 /* Forward decls */
  68 static void who_am_i PROTO((void));
  69
  70 /**********************************************************************
  71 *                                                                     *
  72 *                                                                     *
  73 *     Utility Functions                                               *
  74 *                                                                     *
  75 *                                                                     *
  76 **********************************************************************/
  77
  78 # include <stdio.h>
  79 # include "constants.h"
  80 # include "hspincl.h"
  81 # include "utils.h"
  82
  83 void
  84 process_args(argc,argv)
  85   int argc;
  86   char **argv;
  87 {
  88     BOOLEAN keep_munging_option = FALSE;
  89
  90 /*OLD: progname = argv[0]; */
  91     imports_dirlist     = mklnil();
  92     sys_imports_dirlist = mklnil();
  93
  94     argc--, argv++;
  95
  96     while (argc && argv[0][0] == '-') {
  97
  98         keep_munging_option = TRUE;
  99
 100         while (keep_munging_option && *++*argv != '\0') {
 101             switch(**argv) {
 102
 103             /* -I dir */
 104             case 'I':
 105                     imports_dirlist = lapp(imports_dirlist,*argv+1);
 106                     keep_munging_option = FALSE;
 107                     break;
 108
 109             /* -J dir (for system imports) */
 110             case 'J':
 111                     sys_imports_dirlist = lapp(sys_imports_dirlist,*argv+1);
 112                     keep_munging_option = FALSE;
 113                     break;
 114
 115             case 'g':
 116                     strcpy(PreludeHiSuffix, *argv+1);
 117                     keep_munging_option = FALSE;
 118                     break;
 119
 120             case 'h':
 121                     strcpy(HiSuffix, *argv+1);
 122 /*OLD 95/08:        ExplicitHiSuffixGiven = 1; */
 123                     keep_munging_option = FALSE;
 124                     break;
 125
 126             case 'v':
 127                     who_am_i(); /* identify myself */
 128                     verbose = TRUE;
 129                     break;
 130
 131             case 'N':
 132                     nonstandardFlag = TRUE;
 133                     acceptPrim = TRUE;
 134                     break;
 135
 136             case '3':
 137                     haskell1_3Flag = TRUE;
 138                     break;
 139
 140             case 'S':
 141                     ignoreSCC = FALSE;
 142                     break;
 143
 144             case 'W':
 145                     warnSCC = TRUE;
 146                     break;
 147
 148             case 'p':
 149                     ignorePragmas = TRUE;
 150                     break;
 151
 152             case 'P':
 153                     implicitPrelude = FALSE;
 154                     break;
 155
 156             case 'D':
 157 #ifdef HSP_DEBUG
 158                     { extern int yydebug;
 159                       yydebug = 1;
 160                     }
 161 #endif
 162                     break;
 163
 164             /* -Hn -- Use Hash Table, Size n (if given) */
 165             case 'H':
 166                     hashIds = TRUE;
 167                     if(*(*argv+1)!= '\0')
 168                       hash_table_size = atoi(*argv+1);
 169                     break;
 170             case 'E':
 171                     etags = TRUE;
 172                     break;
 173             }
 174         }
 175         argc--, argv++;
 176     }
 177
 178     if(argc >= 1 && freopen(argv[0], "r", stdin) == NULL) {
 179             fprintf(stderr, "Cannot open %s.\n", argv[0]);
 180             exit(1);
 181     }
 182
 183     if(argc >= 2 && freopen(argv[1], "w", stdout) == NULL) {
 184             fprintf(stderr, "Cannot open %s.\n", argv[1]);
 185             exit(1);
 186     }
 187
 188
 189     /* By default, imports come from the directory of the source file */
 190     if ( argc >= 1 )
 191       {
 192         char *endchar;
 193
 194         input_file_dir = xmalloc (strlen(argv[0]) + 1);
 195         strcpy(input_file_dir, argv[0]);
 196 #ifdef macintosh
 197         endchar = rindex(input_file_dir, (int) ':');
 198 #else
 199         endchar = rindex(input_file_dir, (int) '/');
 200 #endif /* ! macintosh */
 201
 202         if ( endchar == NULL )
 203           {
 204             free(input_file_dir);
 205             input_file_dir = ".";
 206           }
 207         else
 208           *endchar = '\0';
 209       }
 210
 211     /* No input file -- imports come from the current directory first */
 212     else
 213       input_file_dir = ".";
 214
 215     imports_dirlist = mklcons( input_file_dir, imports_dirlist );
 216
 217     if (verbose)
 218       {
 219         fprintf(stderr,"Hash Table Contains %d entries\n",hash_table_size);
 220         if(acceptPrim)
 221           fprintf(stderr,"Allowing special syntax for Unboxed Values\n");
 222       }
 223 }
 224
 225 void
 226 error(s)
 227   char *s;
 228 {
 229 /*OLD:  fprintf(stderr, "%s: Error %s\n", progname, s); */
 230         fprintf(stderr, "PARSER: Error %s\n", s);
 231         exit(1);
 232 }
 233
 234 static void
 235 who_am_i(void)
 236 {
 237   fprintf(stderr,"Glasgow Haskell parser, version %s\n", PARSER_VERSION);
 238 }
 239
 240 tree
 241 mkbinop(s, l, r)
 242   char *s;
 243   tree l, r;
 244 {
 245         return mkap(mkap(mkident(s), l), r);
 246 }
 247
 248 list
 249 lconc(l1, l2)
 250   list l1;
 251   list l2;
 252 {
 253         list t;
 254
 255         if (tlist(l1) == lnil)
 256                 return(l2);
 257         for(t = l1; tlist(ltl(t)) != lnil; t = ltl(t))
 258                 ;
 259         ltl(t) = l2;
 260         return(l1);
 261 }
 262
 263 list
 264 lapp(list l1, VOID_STAR l2)
 265 {
 266         list t;
 267
 268         if (tlist(l1) == lnil)
 269                 return(mklcons(l2, mklnil()));
 270         for(t = l1; tlist(ltl(t)) != lnil; t = ltl(t))
 271                 ;
 272         ltl(t) = mklcons(l2, mklnil());
 273         return(l1);
 274 }
 275
 276
 277 /************** Haskell Infix ops, built on mkap ******************/
 278
 279 tree mkinfixop(s, l, r)
 280   char *s;
 281   tree l, r;
 282 {
 283   tree ap = mkap(mkap(mkident(s), l), r);
 284   ap -> tag = tinfixop;
 285   return ap;
 286 }
 287
 288 tree *
 289 Rginfun(t)
 290  struct Sap *t;
 291 {
 292         if(t -> tag != tinfixop)
 293                 fprintf(stderr, "ginfun: illegal selection; was %d\n", t -> tag);
 294         return(Rgfun((struct Sap *) (t -> Xgfun)));
 295 }
 296
 297 tree *
 298 Rginarg1(t)
 299  struct Sap *t;
 300 {
 301         if(t -> tag != tinfixop)
 302                 fprintf(stderr, "ginarg1: illegal selection; was %d\n", t -> tag);
 303         return(Rgarg((struct Sap *) (t -> Xgfun)));
 304 }
 305
 306 tree *
 307 Rginarg2(t)
 308  struct Sap *t;
 309 {
 310         if(t -> tag != tinfixop)
 311                 fprintf(stderr, "ginarg2: illegal selection; was %d\n", t -> tag);
 312         return(& t -> Xgarg);
 313 }