← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to o/hash.d

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
o/hash.d
 
1
/*
 
2
 Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
 
3
 
 
4
This file is part of GNU Common Lisp, herein referred to as GCL
 
5
 
 
6
GCL is free software; you can redistribute it and/or modify it under
 
7
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
 
8
the Free Software Foundation; either version 2, or (at your option)
 
9
any later version.
 
10
 
 
11
GCL is distributed in the hope that it will be useful, but WITHOUT
 
12
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
 
13
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
 
14
License for more details.
 
15
 
 
16
You should have received a copy of the GNU Library General Public License 
 
17
along with GCL; see the file COPYING.  If not, write to the Free Software
 
18
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 
19
*/
 
20
 
 
21
#define NEED_MP_H
 
22
#include <string.h>
 
23
#include "include.h"
 
24
 
 
25
 
 
26
object sLeq;
 
27
object sLeql;
 
28
object sLequal;
 
29
 
 
30
object sKsize;
 
31
object sKrehash_size;
 
32
object sKrehash_threshold;
 
33
 
 
34
 
 
35
static unsigned int
 
36
hash_eql(x)
 
37
object x;
 
38
{
 
39
        unsigned int h = 0;
 
40
 
 
41
        switch (type_of(x)) {
 
42
        case t_fixnum:
 
43
                return(fix(x));
 
44
 
 
45
        case t_bignum:
 
46
#ifdef GMP
 
47
          { MP_INT *mp = MP(x);
 
48
          int l = mpz_size (mp);
 
49
          mp_limb_t *u = mp->_mp_d;
 
50
          if (l > 5) l = 5;
 
51
          while (-- l >= 0)
 
52
            { h += *u++;}
 
53
          return(h);
 
54
          }
 
55
                
 
56
#else
 
57
             { GEN u = MP(x);
 
58
                  int l = lg(u) - 2;
 
59
                  u += 2;
 
60
                  h += l;
 
61
                  if (l > 5) l = 5;
 
62
                  while (-- l >= 0)
 
63
                    { h += *u++;}
 
64
                  return(h);
 
65
                }
 
66
#endif
 
67
 
 
68
        case t_ratio:
 
69
                return(hash_eql(x->rat.rat_num) + hash_eql(x->rat.rat_den));
 
70
 
 
71
        case t_shortfloat:
 
72
                return(*((int *) &(sf(x))));
 
73
 
 
74
        case t_longfloat:
 
75
                {int *y = (int *) &lf(x);
 
76
                return( *y + *(y+1));}
 
77
 
 
78
        case t_complex:
 
79
                return(hash_eql(x->cmp.cmp_real) + hash_eql(x->cmp.cmp_imag));
 
80
 
 
81
        case t_character:
 
82
                return(char_code(x));
 
83
 
 
84
        default:
 
85
                return((unsigned long)x / 4);
 
86
        }
 
87
}
 
88
 
 
89
static unsigned int
 
90
ihash_equal(x,depth)
 
91
object x;
 
92
int depth;
 
93
{
 
94
        unsigned int h = 0;
 
95
        int i;
 
96
        char *s;
 
97
 
 
98
        cs_check(x);
 
99
 
 
100
BEGIN:
 
101
        if (depth++ >3) return h;
 
102
        switch (type_of(x)) {
 
103
        case t_cons:
 
104
                h += ihash_equal(x->c.c_car,depth);
 
105
                x = x->c.c_cdr;
 
106
                goto BEGIN;
 
107
 
 
108
        case t_string:
 
109
                for (i = x->st.st_fillp, s = x->st.st_self;  i > 0;  --i, s++)
 
110
                        h += (*s & 0377)*12345 + 1;
 
111
                return(h);
 
112
        case t_symbol:
 
113
                /* case t_string could share this code--wfs */
 
114
                {int len=x->st.st_fillp;
 
115
                 s=x->st.st_self;
 
116
                 switch(len) {
 
117
                 case 0: break;
 
118
                 default:
 
119
                 case 4: h+= s[--len] << 24;
 
120
                 case 3: h+= s[--len]<< 16;
 
121
                 case 2: h+= s[1] << 8;
 
122
                 case 1: h+= s[0] ;
 
123
                   
 
124
                   
 
125
                 }
 
126
                 return(h);
 
127
               }
 
128
                   
 
129
        case t_package:  return h;
 
130
        case t_bitvector:
 
131
        {static char ar[10];
 
132
         i = x->bv.bv_fillp;
 
133
         h = h + i;
 
134
         i = i/8;
 
135
         if (i > 10) i= 10;
 
136
         s = x->bv.bv_self;
 
137
         if (x->bv.bv_offset)
 
138
           {int k,j;
 
139
            int e = i;
 
140
            s = ar;
 
141
            /* 8 should be CHAR_SIZE but this needs to be changed
 
142
               everywhere .. */
 
143
            e = e * 8;
 
144
            bzero(ar,sizeof(ar));
 
145
            for (k = x->bv.bv_offset, j = 0;  k < e;  k++, j++)
 
146
              if (x->bv.bv_self[k/8]&(0200>>k%8))
 
147
                ar[j/8]  |= 0200>>j%8;
 
148
          }
 
149
         for (;  i > 0;  --i, s++)
 
150
           h += (*s & 0377)*12345 + 1;
 
151
 
 
152
         return(h);
 
153
       }
 
154
        case t_pathname:
 
155
                h += ihash_equal(x->pn.pn_host,depth);
 
156
                h += ihash_equal(x->pn.pn_device,depth);
 
157
                h += ihash_equal(x->pn.pn_directory,depth);
 
158
                h += ihash_equal(x->pn.pn_name,depth);
 
159
                h += ihash_equal(x->pn.pn_type,depth);
 
160
                h += ihash_equal(x->pn.pn_version,depth);
 
161
                return(h);
 
162
/*  CLTLII says don't descend into structures
 
163
        case t_structure:
 
164
                {unsigned char *s_type;
 
165
                 struct s_data *def;
 
166
                 def=S_DATA(x->str.str_def);
 
167
                 s_type= & SLOT_TYPE(x->str.str_def,0);
 
168
                 h += ihash_equal(def->name,depth);
 
169
                 for (i = 0;  i < def->length;  i++)
 
170
                   if (s_type[i]==0)
 
171
                     h += ihash_equal(x->str.str_self[i],depth);
 
172
                   else
 
173
                     h += ((int)x->str.str_self[i]) + depth++;
 
174
                 return(h);}
 
175
*/
 
176
 
 
177
        default:
 
178
                return(h + hash_eql(x));
 
179
        }
 
180
}
 
181
                
 
182
static object
 
183
FFN(hash_equal)(x,depth)
 
184
object x;
 
185
int depth;
 
186
{
 
187
 
 
188
        return make_fixnum(ihash_equal(x,depth));
 
189
 
 
190
}
 
191
 
 
192
struct htent *
 
193
gethash(key, hashtable)
 
194
object key;
 
195
object hashtable;
 
196
{
 
197
        enum httest htest;
 
198
        int hsize;
 
199
        struct htent *e;
 
200
        object hkey;
 
201
        int i=0, j = -1, k; /* k added by chou */
 
202
        bool b=FALSE;
 
203
 
 
204
        htest = (enum httest)hashtable->ht.ht_test;
 
205
        hsize = hashtable->ht.ht_size;
 
206
        if (htest == htt_eq)
 
207
                i = (long)key / 4;
 
208
        else if (htest == htt_eql)
 
209
                i = hash_eql(key);
 
210
        else if (htest == htt_equal)
 
211
                i = ihash_equal(key,0);
 
212
        i &= 0x7fffffff;
 
213
        for (i %= hsize, k = 0; k < hsize;  i = (i + 1) % hsize, k++) { /* k added by chou */
 
214
                e = &hashtable->ht.ht_self[i];
 
215
                hkey = e->hte_key;
 
216
                if (hkey == OBJNULL) {
 
217
                        if (e->hte_value == OBJNULL)
 
218
                                if (j < 0)
 
219
                                        return(e);
 
220
                                else
 
221
                                        return(&hashtable->ht.ht_self[j]);
 
222
                        else
 
223
                                if (j < 0)
 
224
                                        j = i;
 
225
                                else if (j==i)
 
226
                                  /* this was never returning --wfs
 
227
                                     but looping around with j=0 */
 
228
                                  return(e) 
 
229
                                        ;
 
230
                        continue;
 
231
                }
 
232
                if (htest == htt_eq)
 
233
                        b = key == hkey;
 
234
                else if (htest == htt_eql)
 
235
                        b = eql(key, hkey);
 
236
                else if (htest == htt_equal)
 
237
                        b = equal(key, hkey);
 
238
                if (b)
 
239
                        return(&hashtable->ht.ht_self[i]);
 
240
        }
 
241
        return(&hashtable->ht.ht_self[j]);      /* added by chou */
 
242
}
 
243
 
 
244
static void
 
245
extend_hashtable(object);
 
246
 
 
247
void
 
248
sethash(key, hashtable, value)
 
249
object key, hashtable, value;
 
250
{
 
251
        int i;
 
252
        bool over=FALSE;
 
253
        struct htent *e;
 
254
        
 
255
        i = hashtable->ht.ht_nent + 1;
 
256
        if (type_of(hashtable->ht.ht_rhthresh) == t_fixnum)
 
257
                over = i >= fix(hashtable->ht.ht_rhthresh);
 
258
        else if (type_of(hashtable->ht.ht_rhthresh) == t_shortfloat)
 
259
                over =
 
260
                i >= hashtable->ht.ht_size * sf(hashtable->ht.ht_rhthresh);
 
261
        else if (type_of(hashtable->ht.ht_rhthresh) == t_longfloat)
 
262
                over =
 
263
                i >= hashtable->ht.ht_size * lf(hashtable->ht.ht_rhthresh);
 
264
        if (over)
 
265
                extend_hashtable(hashtable);
 
266
        e = gethash(key, hashtable);
 
267
        if (e->hte_key == OBJNULL)
 
268
                hashtable->ht.ht_nent++;
 
269
        e->hte_key = key;
 
270
        e->hte_value = value;
 
271
}
 
272
        
 
273
static void
 
274
extend_hashtable(hashtable)
 
275
object hashtable;
 
276
{
 
277
        object old;
 
278
        int new_size=0, i;
 
279
 
 
280
        if (type_of(hashtable->ht.ht_rhsize) == t_fixnum)
 
281
                new_size = 
 
282
                hashtable->ht.ht_size + fix(hashtable->ht.ht_rhsize);
 
283
        else if (type_of(hashtable->ht.ht_rhsize) == t_shortfloat)
 
284
                new_size = 
 
285
                hashtable->ht.ht_size * sf(hashtable->ht.ht_rhsize);
 
286
        else if (type_of(hashtable->ht.ht_rhsize) == t_longfloat)
 
287
                new_size = 
 
288
                hashtable->ht.ht_size * lf(hashtable->ht.ht_rhsize);
 
289
        {BEGIN_NO_INTERRUPT;    
 
290
        old = alloc_object(t_hashtable);
 
291
        old->ht = hashtable->ht;
 
292
        vs_push(old);
 
293
        hashtable->ht.ht_self = NULL;
 
294
        hashtable->ht.ht_size = new_size;
 
295
        if (type_of(hashtable->ht.ht_rhthresh) == t_fixnum)
 
296
                hashtable->ht.ht_rhthresh =
 
297
                make_fixnum(fix(hashtable->ht.ht_rhthresh) +
 
298
                            (new_size - old->ht.ht_size));
 
299
        hashtable->ht.ht_self =
 
300
        (struct htent *)alloc_relblock(new_size * sizeof(struct htent));
 
301
        for (i = 0;  i < new_size;  i++) {
 
302
                hashtable->ht.ht_self[i].hte_key = OBJNULL;
 
303
                hashtable->ht.ht_self[i].hte_value = OBJNULL;
 
304
        }
 
305
        for (i = 0;  i < old->ht.ht_size;  i++) {
 
306
                if (old->ht.ht_self[i].hte_key != OBJNULL)
 
307
                        sethash(old->ht.ht_self[i].hte_key,
 
308
                                hashtable,
 
309
                                old->ht.ht_self[i].hte_value);
 
310
        }
 
311
        hashtable->ht.ht_nent = old->ht.ht_nent;
 
312
        vs_popp;
 
313
        END_NO_INTERRUPT;}
 
314
}
 
315
 
 
316
 
 
317
@(defun make_hash_table (&key (test sLeql)
 
318
                              (size `make_fixnum(1024)`)
 
319
                              (rehash_size
 
320
                               `make_shortfloat((shortfloat)1.5)`)
 
321
                              (rehash_threshold
 
322
                               `make_shortfloat((shortfloat)0.7)`)
 
323
                         &aux h)
 
324
        enum httest htt=0;
 
325
        int i;
 
326
@
 
327
        if (test == sLeq || test == sLeq->s.s_gfdef)
 
328
                htt = htt_eq;
 
329
        else if (test == sLeql || test == sLeql->s.s_gfdef)
 
330
                htt = htt_eql;
 
331
        else if (test == sLequal || test == sLequal->s.s_gfdef)
 
332
                htt = htt_equal;
 
333
        else
 
334
                FEerror("~S is an illegal hash-table test function.",
 
335
                        1, test);
 
336
        if (type_of(size) != t_fixnum || 0 < fix(size))
 
337
                ;
 
338
        else
 
339
                FEerror("~S is an illegal hash-table size.", 1, size);
 
340
        if ((type_of(rehash_size) == t_fixnum && 0 < fix(rehash_size)) ||
 
341
            (type_of(rehash_size) == t_shortfloat && 1.0 < sf(rehash_size)) ||
 
342
            (type_of(rehash_size) == t_longfloat && 1.0 < lf(rehash_size)))
 
343
                ;
 
344
        else
 
345
                FEerror("~S is an illegal hash-table rehash-size.",
 
346
                        1, rehash_size);
 
347
        if ((type_of(rehash_threshold) == t_fixnum &&
 
348
            0 < fix(rehash_threshold) && fix(rehash_threshold) < fix(size)) ||
 
349
            (type_of(rehash_threshold) == t_shortfloat &&
 
350
            0.0 < sf(rehash_threshold) && sf(rehash_threshold) < 1.0) ||
 
351
            (type_of(rehash_threshold) == t_longfloat &&
 
352
            0.0 < lf(rehash_threshold) && lf(rehash_threshold) < 1.0))
 
353
                ;
 
354
        else
 
355
                FEerror("~S is an illegal hash-table rehash-threshold.",
 
356
                        1, rehash_threshold);
 
357
        {BEGIN_NO_INTERRUPT;
 
358
        h = alloc_object(t_hashtable);
 
359
        h->ht.ht_test = (short)htt;
 
360
        h->ht.ht_size = fix(size);
 
361
        h->ht.ht_rhsize = rehash_size;
 
362
        h->ht.ht_rhthresh = rehash_threshold;
 
363
        h->ht.ht_nent = 0;
 
364
        h->ht.ht_self = NULL;
 
365
        h->ht.ht_self = (struct htent *)
 
366
        alloc_relblock(fix(size) * sizeof(struct htent));
 
367
        for(i = 0;  i < fix(size);  i++) {
 
368
                h->ht.ht_self[i].hte_key = OBJNULL;
 
369
                h->ht.ht_self[i].hte_value = OBJNULL;
 
370
        }
 
371
        END_NO_INTERRUPT;}
 
372
        @(return h)
 
373
@)
 
374
 
 
375
LFD(Lhash_table_p)(void)
 
376
{
 
377
        check_arg(1);
 
378
 
 
379
        if(type_of(vs_base[0]) == t_hashtable)
 
380
                vs_base[0] = Ct;
 
381
        else   
 
382
                vs_base[0] = Cnil;
 
383
}
 
384
 
 
385
LFD(Lgethash)()
 
386
{
 
387
        int narg;
 
388
        struct htent *e;
 
389
        
 
390
        narg = vs_top - vs_base;
 
391
        if (narg < 2)
 
392
                too_few_arguments();
 
393
        else if (narg == 2)
 
394
                vs_push(Cnil);
 
395
        else if (narg > 3)
 
396
                too_many_arguments();
 
397
        check_type_hash_table(&vs_base[1]);
 
398
        e = gethash(vs_base[0], vs_base[1]);
 
399
        if (e->hte_key != OBJNULL) {
 
400
                vs_base[0] = e->hte_value;
 
401
                vs_base[1] = Ct;
 
402
        } else {
 
403
                vs_base[0] = vs_base[2];
 
404
                vs_base[1] = Cnil;
 
405
        }
 
406
        vs_popp;
 
407
}
 
408
 
 
409
LFD(siLhash_set)()
 
410
{
 
411
        check_arg(3);
 
412
 
 
413
        check_type_hash_table(&vs_base[1]);
 
414
        sethash(vs_base[0], vs_base[1], vs_base[2]);
 
415
        vs_base += 2;
 
416
}
 
417
        
 
418
LFD(Lremhash)()
 
419
{
 
420
        struct htent *e;
 
421
 
 
422
        check_arg(2);
 
423
        check_type_hash_table(&vs_base[1]);
 
424
        e = gethash(vs_base[0], vs_base[1]);
 
425
        if (e->hte_key != OBJNULL) {
 
426
                e->hte_key = OBJNULL;
 
427
                e->hte_value = Cnil;
 
428
                vs_base[1]->ht.ht_nent--;
 
429
                vs_base[0] = Ct;
 
430
        } else
 
431
                vs_base[0] = Cnil;
 
432
        vs_top = vs_base + 1;
 
433
}
 
434
 
 
435
LFD(Lclrhash)()
 
436
{
 
437
        int i;
 
438
 
 
439
        check_arg(1);
 
440
        check_type_hash_table(&vs_base[0]);
 
441
        for(i = 0; i < vs_base[0]->ht.ht_size; i++) {
 
442
                vs_base[0]->ht.ht_self[i].hte_key = OBJNULL;
 
443
                vs_base[0]->ht.ht_self[i].hte_value = OBJNULL;
 
444
        }
 
445
        vs_base[0]->ht.ht_nent = 0;
 
446
}
 
447
 
 
448
LFD(Lhash_table_count)()
 
449
{
 
450
 
 
451
        check_arg(1);
 
452
        check_type_hash_table(&vs_base[0]);
 
453
        vs_base[0] = make_fixnum(vs_base[0]->ht.ht_nent);
 
454
}
 
455
 
 
456
 
 
457
LFD(Lsxhash)()
 
458
{
 
459
        check_arg(1);
 
460
 
 
461
        vs_base[0] = make_fixnum((ihash_equal(vs_base[0],0) & 0x7fffffff));
 
462
}
 
463
 
 
464
LFD(Lmaphash)()
 
465
{
 
466
        object *base = vs_base;
 
467
        object hashtable;
 
468
        int i;
 
469
 
 
470
        check_arg(2);
 
471
        check_type_hash_table(&vs_base[1]);
 
472
        hashtable = vs_base[1];
 
473
        for (i = 0;  i < hashtable->ht.ht_size;  i++) {
 
474
                if(hashtable->ht.ht_self[i].hte_key != OBJNULL)
 
475
                        ifuncall2(base[0],
 
476
                                  hashtable->ht.ht_self[i].hte_key,
 
477
                                  hashtable->ht.ht_self[i].hte_value);
 
478
        }
 
479
        vs_base[0] = Cnil;
 
480
        vs_popp;
 
481
}
 
482
 
 
483
DEFUN_NEW("NEXT-HASH-TABLE-ENTRY",object,fSnext_hash_table_entry,SI,2,2,NONE,OO,OO,OO,OO,(object table,object ind),"For HASH-TABLE and for index I return three values: NEXT-START, the next KEY and its  VALUE.   NEXT-START will be -1 if there are no more entries, otherwise it will be a value suitable for passing as an index")
 
484
{ int i = fix(ind);
 
485
  check_type_hash_table(&table);
 
486
  if ( i < 0) { FEerror("needs non negative index",0);}
 
487
  while ( i <  table->ht.ht_size) {
 
488
     if (table->ht.ht_self[i].hte_key != OBJNULL) {
 
489
         RETURN(3,object,make_fixnum(i+1),
 
490
                        (RV(table->ht.ht_self[i].hte_key),
 
491
                         RV(table->ht.ht_self[i].hte_value)));}
 
492
        i++;}
 
493
   RETURN(3,object,small_fixnum(-1),(RV(sLnil),RV(sLnil)));
 
494
}
 
495
 
 
496
DEFUN_NEW("HASH-TABLE-TEST",object,fLhash_table_test,LISP,1,1,NONE,OO,OO,OO,OO,(object table),
 
497
 "Given a HASH-TABLE return a symbol which specifies the function used in its test") 
 
498
{ switch(table->ht.ht_test) {
 
499
     case htt_equal: RETURN1(sLequal);
 
500
     case htt_eq: RETURN1(sLeq);
 
501
     case htt_eql: RETURN1(sLeql);
 
502
     }
 
503
  FEerror("not able to get hash table test for ~a",1,table);
 
504
  RETURN1(sLnil);
 
505
}
 
506
 
 
507
DEFUN_NEW("HASH-TABLE-SIZE",object,fLhash_table_size,LISP,1,1,NONE,OO,OO,OO,OO,(object table),"")
 
508
{
 
509
  RETURN1(make_fixnum(table->ht.ht_size));
 
510
 
 
511
}
 
512
 
 
513
 
 
514
 
 
515
void
 
516
gcl_init_hash()
 
517
{
 
518
        sLeq = make_ordinary("EQ");
 
519
        sLeql = make_ordinary("EQL");
 
520
        sLequal = make_ordinary("EQUAL");
 
521
        sKsize = make_keyword("SIZE");
 
522
        sKtest = make_keyword("TEST");
 
523
        sKrehash_size = make_keyword("REHASH-SIZE");
 
524
        sKrehash_threshold = make_keyword("REHASH-THRESHOLD");
 
525
        
 
526
        make_function("MAKE-HASH-TABLE", Lmake_hash_table);
 
527
        make_function("HASH-TABLE-P", Lhash_table_p);
 
528
        make_function("GETHASH", Lgethash);
 
529
        make_function("REMHASH", Lremhash);
 
530
        make_function("MAPHASH", Lmaphash);
 
531
        make_function("CLRHASH", Lclrhash);
 
532
        make_function("HASH-TABLE-COUNT", Lhash_table_count);
 
533
        make_function("SXHASH", Lsxhash);
 
534
        make_si_sfun("HASH-EQUAL",hash_equal,ARGTYPE2(f_object,f_fixnum)
 
535
                                                | RESTYPE(f_object));
 
536
        make_si_function("HASH-SET", siLhash_set);
 
537
}