ghc/compiler/parser/id.c

   1 /**********************************************************************
   2 *                                                                     *
   3 *                                                                     *
   4 *      Identifier Processing                                          *
   5 *                                                                     *
   6 *                                                                     *
   7 **********************************************************************/
   8
   9 #include <stdio.h>
  10
  11 #include "hspincl.h"
  12 #include "constants.h"
  13 #include "id.h"
  14 #include "utils.h"
  15
  16 /* partain: special version for strings that may have NULs (etc) in them
  17    (used in UgenUtil.lhs)
  18 */
  19 long
  20 get_hstring_len(hs)
  21   hstring hs;
  22 {
  23     return(hs->len);
  24 }
  25
  26 char *
  27 get_hstring_bytes(hs)
  28   hstring hs;
  29 {
  30   return(hs->bytes);
  31 }
  32
  33 hstring
  34 installHstring(length, s)
  35   int  length;
  36   char *s;
  37 {
  38   char *p;
  39   hstring str;
  40   int i;
  41
  42 /* fprintf(stderr, "installHstring: %d, %s\n",length, s); */
  43
  44   if (length > 999999) { /* too long */
  45       fprintf(stderr,"String length more than six digits\n");
  46       exit(1);
  47   } else if (length < 0) { /* too short */
  48       fprintf(stderr,"String length < 0 !!\n");
  49       abort();
  50   }
  51
  52   /* alloc the struct and store the length */
  53   str = (hstring) xmalloc(sizeof(Hstring));
  54   str->len = length;
  55
  56   if (length == 0) {
  57      str->bytes = "";
  58
  59   } else {
  60      p = xmalloc(length);
  61
  62      /* now store the string */
  63      for (i = 0; i < length; i++) {
  64        p[i] = s[i];
  65      }
  66      str->bytes = p;
  67   }
  68   return str;
  69 }
  70
  71
  72 /**********************************************************************
  73 *                                                                     *
  74 *                                                                     *
  75 *      Hashed Identifiers                                             *
  76 *                                                                     *
  77 *                                                                     *
  78 **********************************************************************/
  79
  80
  81 extern BOOLEAN hashIds;                         /* Whether to use hashed ids. */
  82
  83 unsigned hash_table_size = HASH_TABLE_SIZE;
  84
  85 static char **hashtab = NULL;
  86
  87 static unsigned  max_hash_table_entries = 0;
  88
  89 void
  90 hash_init()
  91 {
  92   if(!hashIds) {
  93     /*NOTHING*/;
  94
  95   } else {
  96
  97   /* Create an initialised hash table */
  98   hashtab = (char **) calloc( hash_table_size, sizeof(char *) );
  99   if(hashtab == NULL)
 100     {
 101       fprintf(stderr,"Cannot allocate a hash table with %d entries -- insufficient memory\n",hash_table_size);
 102       exit(1);
 103     }
 104 #ifdef HSP_DEBUG
 105   fprintf(stderr,"hashtab = %x\n",hashtab);
 106 #endif
 107
 108   /* Allow no more than 90% occupancy -- Divide first to avoid overflows with BIG tables! */
 109   max_hash_table_entries = (hash_table_size / 10) * 9;
 110   }
 111 }
 112
 113 void
 114 print_hash_table()
 115 {
 116   if(hashIds)
 117     {
 118       unsigned i;
 119
 120       printf("%u ",hash_table_size);
 121
 122       for(i=0; i < hash_table_size; ++i)
 123         if(hashtab[i] != NULL)
 124           printf("(%u,%s) ",i,hashtab[i]);
 125     }
 126 }
 127
 128
 129 long int
 130 hash_index(ident)
 131   id ident;
 132 {
 133   return((char **) /* YURGH */ ident - hashtab);
 134 }
 135
 136
 137 /*
 138   The hash function.  Returns 0 for Null strings.
 139 */
 140
 141 static unsigned hash_fn(char *ident)
 142 {
 143   unsigned len = (unsigned) strlen(ident);
 144   unsigned res;
 145
 146   if(*ident == '\0')
 147     return( 0 );
 148
 149   /* does not work well for hash tables with more than 35K elements */
 150   res = (((unsigned)ident[0]*631)+((unsigned)ident[len/2-1]*217)+((unsigned)ident[len-1]*43)+len)
 151           % hash_table_size;
 152
 153 #ifdef HSP_DEBUG
 154   fprintf(stderr,"\"%s\" hashes to %d\n",ident,res);
 155 #endif
 156   return(res);
 157 }
 158
 159
 160 /*
 161   Install a literal identifier, such as "+" in hsparser.
 162   If we are not using hashing, just return the string.
 163 */
 164
 165 id
 166 install_literal(s)
 167   char *s;
 168 {
 169   return( hashIds? installid(s): s);
 170 }
 171
 172
 173 char *
 174 id_to_string(sp)
 175   id sp;
 176 {
 177   return( hashIds? *(char **)sp: (char *)sp );
 178 }
 179
 180 id
 181 installid(s)
 182   char *s;
 183 {
 184   unsigned hash, count;
 185
 186   if(!hashIds)
 187     return(xstrdup(s));
 188
 189   for(hash = hash_fn(s),count=0; count<max_hash_table_entries; ++hash,++count)
 190     {
 191       if (hash >= hash_table_size) hash = 0;
 192
 193       if(hashtab[hash] == NULL)
 194         {
 195           hashtab[hash] = xstrdup(s);
 196 #ifdef HSP_DEBUG
 197           fprintf(stderr,"New Hash Entry %x\n",(char *)&hashtab[hash]);
 198 #endif
 199           if ( count >= 100 ) {
 200             fprintf(stderr, "installid: %d collisions for %s\n", count, s);
 201           }
 202
 203           return((char *)&hashtab[hash]);
 204         }
 205
 206       if(strcmp(hashtab[hash],s) == 0)
 207         {
 208 #ifdef HSP_DEBUG
 209           fprintf(stderr,"Old Hash Entry %x (%s)\n",(char *)&hashtab[hash],hashtab[hash]);
 210 #endif
 211           if ( count >= 100 ) {
 212             fprintf(stderr, "installid: %d collisions for %s\n", count, s);
 213           }
 214
 215           return((char *)&hashtab[hash]);
 216         }
 217     }
 218   fprintf(stderr,"Hash Table Contains more than %d entries -- make larger?\n",max_hash_table_entries);
 219   exit(1);
 220 }
 221
 222 /**********************************************************************
 223 *                                                                     *
 224 *                                                                     *
 225 *     Qualified Ids                                                   *
 226 *                                                                     *
 227 *                                                                     *
 228 **********************************************************************/
 229
 230 id
 231 qid_to_id(q)
 232   qid q;
 233 {
 234   switch(tqid(q))
 235     {
 236       case noqual:
 237         return(gnoqual((struct Snoqual *)q));
 238       case aqual:
 239         return(gqualname((struct Saqual *)q));
 240       case gid:
 241         return(gidname((struct Sgid *)q));
 242     }
 243 }
 244
 245 char *
 246 qid_to_string(q)
 247   qid q;
 248 {
 249   return(id_to_string(qid_to_id(q)));
 250 }
 251
 252 char *
 253 qid_to_mod(q)
 254   qid q;
 255 {
 256   switch(tqid(q))
 257     {
 258       case noqual:
 259         return(NULL);
 260       case aqual:
 261         return(id_to_string(gqualmod((struct Saqual *)q)));
 262       case gid:
 263         return(NULL);
 264     }
 265 }
 266
 267 char *
 268 qid_to_pmod(q)
 269   qid q;
 270 {
 271   char *mod = qid_to_mod(q);
 272   if (mod == NULL) mod = "?";
 273   return mod;
 274 }
 275
 276 qid
 277 creategid(i)
 278   long i;
 279 {
 280   switch(i) {
 281     case -2:
 282       return(mkgid(i,install_literal("->")));
 283     case -1:
 284       return(mkgid(i,install_literal("[]")));
 285     case  0:
 286       return(mkgid(i,install_literal("()")));
 287     default:
 288       {
 289       char tmp[64]; int c = 0;
 290       tmp[c++] = '(';
 291       while (c <= i) tmp[c++] = ',';
 292       tmp[c++] = ')';
 293       tmp[c]   = '\0';
 294       return(mkgid(i,installid(tmp)));
 295       }
 296   }
 297 }
 298
 299 /**********************************************************************
 300 *                                                                     *
 301 *                                                                     *
 302 *     Memory Allocation                                               *
 303 *                                                                     *
 304 *                                                                     *
 305 **********************************************************************/
 306
 307 /* Malloc with error checking */
 308
 309 char *
 310 xmalloc(length)
 311 unsigned length;
 312 {
 313     char *stuff = malloc(length);
 314
 315     if (stuff == NULL) {
 316         fprintf(stderr, "xmalloc failed on a request for %d bytes\n", length);
 317         exit(1);
 318     }
 319     return (stuff);
 320 }
 321
 322 char *
 323 xrealloc(ptr, length)
 324 char *ptr;
 325 unsigned length;
 326 {
 327     char *stuff = realloc(ptr, length);
 328
 329     if (stuff == NULL) {
 330         fprintf(stderr, "xrealloc failed on a request for %d bytes\n", length);
 331         exit(1);
 332     }
 333     return (stuff);
 334 }
 335
 336 /* Strdup with error checking */
 337
 338 char *
 339 xstrdup(s)
 340 char *s;
 341 {
 342     unsigned len = strlen(s);
 343     return xstrndup(s, len);
 344 }
 345
 346 /*
 347  * Strdup for possibly unterminated strings (e.g. substrings of longer strings)
 348  * with error checking.  Handles NULs as well.
 349  */
 350
 351 char *
 352 xstrndup(s, len)
 353 char *s;
 354 unsigned len;
 355 {
 356     char *p = xmalloc(len + 1);
 357
 358     bcopy(s, p, len);
 359     p[len] = '\0';
 360
 361     return (p);
 362 }