/[gcl]/gcl/o/hash.d
ViewVC logotype

Diff of /gcl/o/hash.d

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.13 by camm, Sat Nov 27 22:19:35 2004 UTC revision 1.14 by camm, Fri Jun 10 15:35:05 2005 UTC
# Line 31  object sKsize; Line 31  object sKsize;
31  object sKrehash_size;  object sKrehash_size;
32  object sKrehash_threshold;  object sKrehash_threshold;
33    
34    #define MHSH(a_) ((a_) & ~(((unsigned long)1)<<(sizeof(a_)*CHAR_SIZE-1)))
35    
36  static unsigned int  static unsigned long
37  hash_eql(x)  hash_eql(object x) {
 object x;  
 {  
         unsigned int h = 0;  
   
         switch (type_of(x)) {  
         case t_fixnum:  
                 return(fix(x));  
   
         case t_bignum:  
 #ifdef GMP  
           { MP_INT *mp = MP(x);  
           int l = mpz_size (mp);  
           mp_limb_t *u = mp->_mp_d;  
           if (l > 5) l = 5;  
           while (-- l >= 0)  
             { h += *u++;}  
           return(h);  
           }  
                   
 #else  
              { GEN u = MP(x);  
                   int l = lg(u) - 2;  
                   u += 2;  
                   h += l;  
                   if (l > 5) l = 5;  
                   while (-- l >= 0)  
                     { h += *u++;}  
                   return(h);  
                 }  
 #endif  
   
         case t_ratio:  
                 return(hash_eql(x->rat.rat_num) + hash_eql(x->rat.rat_den));  
   
         case t_shortfloat:  
                 return(*((int *) &(sf(x))));  
   
         case t_longfloat:  
                 {int *y = (int *) &lf(x);  
                 return( *y + *(y+1));}  
38    
39          case t_complex:    unsigned long h = 0;
                 return(hash_eql(x->cmp.cmp_real) + hash_eql(x->cmp.cmp_imag));  
40    
41          case t_character:    switch (type_of(x)) {
42                  return(char_code(x));    case t_fixnum:
43        h=fix(x);
44        h ^= (h >> 11);
45        h ^= (h <<  7) & 0x9D2C5680U;
46        h ^= (h << 15) & 0xEFC60000U;
47        h ^= (h >> 18);
48        break;
49      case t_bignum:
50        {
51          MP_INT *mp = MP(x);
52          int l = mpz_size (mp);
53          mp_limb_t *u = mp->_mp_d;
54          if (l > 5) l = 5;
55          while (-- l >= 0)
56            h += *u++;
57        }
58        break;
59      case t_ratio:
60        h=hash_eql(x->rat.rat_num) + hash_eql(x->rat.rat_den);
61        break;
62      case t_shortfloat:  /*FIXME, sizeof int = sizeof float*/
63        h=*((int *) &(sf(x)));
64        break;
65      case t_longfloat:
66        {
67          int *y = (int *) &lf(x);
68          h= *y + *(y+1);
69        }
70        break;
71      case t_complex:
72        h=hash_eql(x->cmp.cmp_real) + hash_eql(x->cmp.cmp_imag);
73        break;
74      case t_character:
75        h=char_code(x);
76        break;
77      default:
78        h=((unsigned long)x / sizeof(x));
79        break;
80      }
81    
82      return MHSH(h);
83    
         default:  
                 return((unsigned long)x / 4);  
         }  
84  }  }
85    
86  static unsigned int  #define ihash_equal(a_,b_) ((type_of(a_)==t_symbol && (a_)->s.s_hash) ? (a_)->s.s_hash : ihash_equal1(a_,b_))
87  ihash_equal(x,depth)  unsigned long
88  object x;  ihash_equal1(object x,int depth) {
89  int depth;  
90  {    enum type tx;
91          unsigned int h = 0;    unsigned long h = 0;
92          int i;    long i;
93          char *s;    char *s;
94      
95          cs_check(x);    cs_check(x);
96    
97  BEGIN:  BEGIN:
98          if (depth++ >3) return h;    if (depth++ <=3)
99          switch (type_of(x)) {      switch ((tx=type_of(x))) {
100          case t_cons:      case t_cons:
101                  h += ihash_equal(x->c.c_car,depth);        h += ihash_equal(x->c.c_car,depth);
102                  x = x->c.c_cdr;        x = x->c.c_cdr;
103                  goto BEGIN;        goto BEGIN;
104          break;
105          case t_string:      case t_symbol:
106                  for (i = x->st.st_fillp, s = x->st.st_self;  i > 0;  --i, s++)      case t_string:
107                          h += (*s & 0377)*12345 + 1;        {
108                  return(h);          long len=x->st.st_fillp;
109          case t_symbol:          s=x->st.st_self;
110                  /* case t_string could share this code--wfs */          len=len>sizeof(len) ? sizeof(len) : len;
111                  {int len=x->st.st_fillp;          for (s+=len-1;len--;s--)
112                   s=x->st.st_self;            h+= *s << CHAR_SIZE*len;
113                   switch(len) {        }
114                   case 0: break;        break;
115                   default:  
116                   case 4: h+= s[--len] << 24;      case t_package:
117                   case 3: h+= s[--len]<< 16;        break;
118                   case 2: h+= s[1] << 8;      case t_bitvector:
119                   case 1: h+= s[0] ;        {
120                              static char ar[10];
121                              i = x->bv.bv_fillp;
122                   }          h += i;
123                   return(h);          i = i/8;
124                 }          if (i > 10) i= 10;
125                              s = x->bv.bv_self;
126          case t_package:  return h;          if (x->bv.bv_offset) {
127          case t_bitvector:            long k,j,e=i;
128          {static char ar[10];            s = ar;
129           i = x->bv.bv_fillp;            /* 8 should be CHAR_SIZE but this needs to be changed
130           h = h + i;               everywhere .. */
131           i = i/8;            e = e * 8;
132           if (i > 10) i= 10;            bzero(ar,sizeof(ar));
133           s = x->bv.bv_self;            for (k = x->bv.bv_offset, j = 0;  k < e;  k++, j++)
134           if (x->bv.bv_offset)              if (x->bv.bv_self[k/8]&(0200>>k%8))
135             {int k,j;                ar[j/8]  |= 0200>>j%8;
136              int e = i;          }
137              s = ar;          for (;  i > 0;  --i, s++)
138              /* 8 should be CHAR_SIZE but this needs to be changed            h += (*s & 0377)*12345 + 1;
139                 everywhere .. */        }
140              e = e * 8;        break;
141              bzero(ar,sizeof(ar));      case t_pathname:
142              for (k = x->bv.bv_offset, j = 0;  k < e;  k++, j++)        h += ihash_equal(x->pn.pn_host,depth);
143                if (x->bv.bv_self[k/8]&(0200>>k%8))        h += ihash_equal(x->pn.pn_device,depth);
144                  ar[j/8]  |= 0200>>j%8;        h += ihash_equal(x->pn.pn_directory,depth);
145            }        h += ihash_equal(x->pn.pn_name,depth);
146           for (;  i > 0;  --i, s++)        h += ihash_equal(x->pn.pn_type,depth);
147             h += (*s & 0377)*12345 + 1;        /* version is ignored unless logical host */
148          if ((type_of(x->pn.pn_host) == t_string) &&
149           return(h);            (pathname_lookup(x->pn.pn_host,sSApathname_logicalA) != Cnil))
150         }          h += ihash_equal(x->pn.pn_version,depth);
151          case t_pathname:        h += ihash_equal(x->pn.pn_version,depth);
152                  h += ihash_equal(x->pn.pn_host,depth);        break;
                 h += ihash_equal(x->pn.pn_device,depth);  
                 h += ihash_equal(x->pn.pn_directory,depth);  
                 h += ihash_equal(x->pn.pn_name,depth);  
                 h += ihash_equal(x->pn.pn_type,depth);  
                 /* version is ignored unless logical host */  
                 if ((type_of(x->pn.pn_host) == t_string) &&  
                     (pathname_lookup(x->pn.pn_host,sSApathname_logicalA) != Cnil))  
                         h += ihash_equal(x->pn.pn_version,depth);  
                 h += ihash_equal(x->pn.pn_version,depth);  
                 return(h);  
153  /*  CLTLII says don't descend into structures  /*  CLTLII says don't descend into structures
154          case t_structure:          case t_structure:
155                  {unsigned char *s_type;                  {unsigned char *s_type;
# Line 178  BEGIN: Line 165  BEGIN:
165                   return(h);}                   return(h);}
166  */  */
167    
168          default:      default:
169                  return(h + hash_eql(x));        h +=  hash_eql(x);
170          }        break;
171  }      }
172                      
173  static object    return MHSH(h);
 FFN(hash_equal)(x,depth)  
 object x;  
 int depth;  
 {  
174    
175          return make_fixnum(ihash_equal(x,depth));  }
176    
177            
178    static object
179    FFN(hash_equal)(object x,int depth) {
180      return make_fixnum(ihash_equal(x,depth));
181  }  }
182    
183  struct htent *  struct htent *
184  gethash(key, hashtable)  gethash(object key, object hashtable) {
185  object key;  
186  object hashtable;    enum httest htest;
187  {    long hsize,j,s,q;
188          enum httest htest;    struct htent *e,*e1;
189          int hsize;    object hkey;
190          struct htent *e;    unsigned long i=0;
191          object hkey;    bool (*f)(object,object)=NULL;
192          int i=0, j = -1, k; /* k added by chou */    
193          bool b=FALSE;    htest = (enum httest)hashtable->ht.ht_test;
194      hsize = hashtable->ht.ht_size;
195          htest = (enum httest)hashtable->ht.ht_test;    switch (htest) {
196          hsize = hashtable->ht.ht_size;    case htt_eq:
197          if (htest == htt_eq)      i = (long)key / sizeof(key);
198                  i = (long)key / 4;      break;
199          else if (htest == htt_eql)    case htt_eql:
200                  i = hash_eql(key);      i = hash_eql(key);
201          else if (htest == htt_equal)      f=eql;
202                  i = ihash_equal(key,0);      break;
203          /*FIXME 64*/    case htt_equal:
204          i &= 0x7fffffff;      i = ihash_equal(key,0);
205          for (i %= hsize, k = 0; k < hsize;  i = (i + 1) % hsize, k++) { /* k added by chou */      f=equal;
206                  e = &hashtable->ht.ht_self[i];      break;
207                  hkey = e->hte_key;    }
208                  if (hkey == OBJNULL) {    
209                          if (e->hte_value == OBJNULL)    i%=hsize;
210                                  if (j < 0)    s=i;
211                                          return(e);    q=hsize;
212                                  else    e=e1=NULL;
213                                          return(&hashtable->ht.ht_self[j]);   SEARCH:
214                          else    for (j=s;j<q;j++) {
215                                  if (j < 0)      e = &hashtable->ht.ht_self[j];
216                                          j = i;      hkey = e->hte_key;
217                                  else if (j==i)      if (hkey==OBJNULL) {
218                                    /* this was never returning --wfs        if (e->hte_value==OBJNULL) return e1 ? e1 : e;
219                                       but looping around with j=0 */        if (!e1) e1=e;
220                                    return(e)      } else
221                                          ;        if (f ? f(key,hkey) : key==hkey) return e;
222                          continue;    }
223                  }    if (s) {
224                  if (htest == htt_eq)      q=s;
225                          b = key == hkey;      s=0;
226                  else if (htest == htt_eql)      goto SEARCH;
227                          b = eql(key, hkey);    }
228                  else if (htest == htt_equal)    FEerror("gethash error",0);
229                          b = equal(key, hkey);    return NULL;
                 if (b)  
                         return(&hashtable->ht.ht_self[i]);  
         }  
         return(&hashtable->ht.ht_self[j]);      /* added by chou */  
230  }  }
231    
232  static void  static void
# Line 464  LFD(Lsxhash)() Line 447  LFD(Lsxhash)()
447          check_arg(1);          check_arg(1);
448    
449          /*FIXME 64*/          /*FIXME 64*/
450          vs_base[0] = make_fixnum((ihash_equal(vs_base[0],0) & 0x7fffffff));          vs_base[0] = make_fixnum(ihash_equal(vs_base[0],0)/*  & 0x7fffffff */);
451  }  }
452    
453  LFD(Lmaphash)()  LFD(Lmaphash)()

Legend:
Removed from v.1.13  
changed lines
  Added in v.1.14

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26