home *** CD-ROM | disk | FTP | other *** search
/ Il CD di internet / CD.iso / SOURCE / D / CLISP / CLISPSRC.TAR / clisp-1995-01-01 / src / hashtabl.d < prev    next >
Encoding:
Text File  |  1994-10-15  |  67.7 KB  |  1,521 lines
  1. # Hash-Tabellen in CLISP
  2. # Bruno Haible 15.10.1994
  3.  
  4. #include "lispbibl.c"
  5. #include "arilev0.c" # fⁿr Hashcode-Berechnung
  6. #include "aridecl.c" # fⁿr Short-Floats
  7.  
  8.  
  9. # Aufbau einer Hash-Tabelle:
  10. # Es werden Paare (Key . Value) abgelegt.
  11. # In einem Vektor, der durch (hashcode Key) indiziert wird.
  12. # Damit ein laufendes MAPHASH von einer GC unbeeinflu▀t bleibt, wird dieser
  13. # Vektor bei GC nicht reorganisiert. Da aber bei GC jeder (hashcode Key)
  14. # sich Σndern kann, bauen wir eine weitere Indizierungsstufe ein:
  15. # (hashcode Key) indiziert einen Index-Vektor; dort steht ein Index in
  16. # den Key-Value-Vektor, und dort befindet sich (Key . Value).
  17. # Um Speicherplatz zu sparen, legen wir nicht ein Cons (Key . Value)
  18. # im Vektor ab, sondern einfach Key und Value hintereinander.
  19. # Kollisionen [mehrere Keys haben denselben (hascode Key)] m÷chte man durch
  20. # Listen beheben. Da aber der Key-Value-Vektor (wieder wegen MAPHASH) bei GC
  21. # unbeeinflu▀t bleiben soll und GC die Menge der Kollisionen verΣndert,
  22. # brauchen wir einen weiteren Index-Vektor, genannt Next-Vektor, der
  23. # "parallel" zum Key-Value-Vektor liegt und eine "Listen"struktur enthΣlt.
  24. # Skizze:
  25. #   Key --> (hashcode Key) als Index in Index-Vaktor.
  26. #   Key1 --> 3, Key2 --> 1, Key4 --> 3.
  27. #   Index-Vektor      #( nix {IndexKey2} nix {IndexKey1,IndexKey4} nix ... )
  28. #                   = #( nix 1 nix 0 nix ... )
  29. #   Next-Vektor       #(     3        nix       leer      nix      leer   )
  30. #   Key-Value-Vektor  #( Key1 Val1 Key2 Val2 leer leer Key4 Val4 leer leer)
  31. # Zugriff auf ein (Key . Value) - Paar geschieht also folgenderma▀en:
  32. #   index := (aref Index-Vektor (hashcode Key))
  33. #   until index = nix
  34. #     if (eql Key (aref KVVektor 2*index)) return (aref KVVektor 2*index+1)
  35. #     index := (aref Next-Vektor index) ; "CDR" der Liste nehmen
  36. #   return notfound.
  37. # Wird Index-Vektor vergr÷▀ert, mⁿssen alle Hashcodes und der Inhalt von
  38. # Index-Vektor und der Inhalt von Next-Vektor neu berechnet werden.
  39. # Werden Next-Vektor und Key-Value-Vektor vergr÷▀ert, so k÷nnen die
  40. # restlichen Elemente mit "leer" gefⁿllt werden, ohne da▀ ein Hashcode neu
  41. # berechnet werden mⁿ▀te.
  42. # Damit nach CLRHASH oder vielfachem REMHASH, wenn eine Tabelle viel
  43. # weniger Elemente enthΣlt als ihre KapazitΣt, ein MAPHASH schnell geht,
  44. # k÷nnte man die EintrΣge im Key-Value-Vektor "links gepackt" halten, d.h.
  45. # alle "leer" kommen rechts. Dann braucht man bei MAPHASH nur die Elemente
  46. # count-1,...,1,0 des Key-Value-Vektors abzugrasen. Aber REMHASH mu▀
  47. # - nachdem es eine Lⁿcke gelassen hat - das hinterste Key-Value-Paar
  48. # (Nummer count-1) in die Lⁿcke umfⁿllen.
  49. # Wir behandeln solche FΣlle dadurch, da▀ wir bei CLRHASH und REMHASH
  50. # eventuell den Key-Value-Vektor und den Next-Vektor verkleinern.
  51. # Damit PUTHASH einen freien Eintrag findet, halten wir die "leer" im
  52. # Next-Vektor in einer Frei"liste".
  53. # Die LΣngen von Index-Vektor und Next-Vektor sind unabhΣngig voneinander.
  54. # Wir wΣhlen sie hier im VerhΣltnis 2:1.
  55. # Die Hash-Tabelle wird vergr÷▀ert, wenn die Freiliste leer ist, d.h.
  56. # COUNT > MAXCOUNT wird. Dabei werden MAXCOUNT und SIZE mit REHASH-SIZE (>1)
  57. # multipliziert.
  58. # Die Hash-Tabelle wird verkleinert, wenn COUNT < MINCOUNT wird. Dabei
  59. # werden MAXCOUNT und SIZE mit 1/REHASH-SIZE (<1) multipliziert. Damit nach
  60. # einer Vergr÷▀erung der Tabelle COUNT gleichviel nach oben wie nach unten
  61. # variieren kann (auf einer logarithmischen Skala), wΣhlen wir
  62. # MINCOUNT = MAXCOUNT / REHASH-SIZE^2 .
  63.  
  64. # Datenstruktur der Hash-Tabelle (siehe LISPBIBL.D):
  65. # recflags codiert den Typ und den Zustand der Hash-Tabelle:
  66. #   Bit 0 gesetzt, wenn EQ-Hashtabelle
  67. #   Bit 1 gesetzt, wenn EQL-Hashtabelle
  68. #   Bit 2 gesetzt, wenn EQUAL-Hashtabelle
  69. #   Bit 3-6 =0
  70. #   Bit 7 gesetzt, wenn Tabelle nach GC reorganisiert werden mu▀
  71. # ht_size                Fixnum>0 = LΣnge der ITABLE
  72. # ht_maxcount            Fixnum>0 = LΣnge der NTABLE
  73. # ht_itable              Index-Vektor der LΣnge SIZE, enthΣlt Indizes
  74. # ht_ntable              Next-Vektor der LΣnge MAXCOUNT, enthΣlt Indizes
  75. # ht_kvtable             Key-Value-Vektor, Vektor der LΣnge 2*MAXCOUNT
  76. # ht_freelist            Start-Index der Freiliste im Next-Vektor
  77. # ht_count               Anzahl der EintrΣge in der Table, Fixnum >=0, <=MAXCOUNT
  78. # ht_rehash_size         Wachstumsrate bei Reorganisation. Float >1.1
  79. # ht_mincount_threshold  VerhΣltnis MINCOUNT/MAXCOUNT = 1/rehash-size^2
  80. # ht_mincount            Fixnum>=0, untere Grenze fⁿr COUNT
  81. # Eintrag "leer" im Key-Value-Vektor ist = #<UNBOUND>.
  82. # Eintrag "leer" im Next-Vektor ist durch die Freiliste gefⁿllt.
  83. # Eintrag "nix" im Index-Vektor und im Next-Vektor ist = #<UNBOUND>.
  84.   #define leer  unbound
  85.   #define nix   unbound
  86.  
  87. # Rotiert einen Hashcode x um n Bits nach links (0<n<32).
  88. # rotate_left(n,x)
  89.   #if !(defined(WATCOM) && defined(__INLINE_FUNCTIONS__))
  90.     #define rotate_left(n,x)  (((x) << (n)) | ((x) >> (32-(n))))
  91.   #else
  92.     #define rotate_left(n,x)  _lrotl(x,n)
  93.   #endif
  94.  
  95. # Mischt zwei Hashcodes.
  96. # Der eine wird um 5 Bit rotiert, dann der andere draufgeXORt.
  97.   #define misch(x1,x2) (rotate_left(5,x1) ^ (x2))
  98.  
  99. # UP: Berechnet den EQ-Hashcode eines Objekts.
  100. # hashcode1(obj)
  101. # Er ist nur bis zur nΣchsten GC gⁿltig.
  102. # Aus (eq X Y) folgt (= (hashcode1 X) (hashcode1 Y)).
  103. # > obj: ein Objekt
  104. # < ergebnis: Hashcode, eine 32-Bit-Zahl
  105.   local uint32 hashcode1 (object obj);
  106.   #ifdef WIDE
  107.     #define hashcode1(obj)  ((uint32)untype(obj))
  108.   #else
  109.     #define hashcode1(obj)  ((uint32)(obj)) # Adresse (Bits 23..0) und Typinfo
  110.   #endif
  111.  
  112. # UP: Berechnet den EQL-Hashcode eines Objekts.
  113. # hashcode2(obj)
  114. # Er ist nur bis zur nΣchsten GC gⁿltig.
  115. # Aus (eql X Y) folgt (= (hashcode2 X) (hashcode2 Y)).
  116. # > obj: ein Objekt
  117. # < ergebnis: Hashcode, eine 32-Bit-Zahl
  118.   local uint32 hashcode2 (object obj);
  119. # Hilfsfunktionen bei bekanntem Typ:
  120.   # Fixnum: Fixnum-Wert
  121.   local uint32 hashcode_fixnum (object obj);
  122.   #if 0
  123.   local uint32 hashcode_fixnum(obj)
  124.     var reg1 object obj;
  125.     { return hashcode1(obj); }
  126.   #else
  127.   #define hashcode_fixnum(obj)  hashcode1(obj)
  128.   #endif
  129.   # Bignum: LΣnge*2 + (MSD*2^16 + LSD)
  130.   local uint32 hashcode_bignum (object obj);
  131.   local uint32 hashcode_bignum(obj)
  132.     var reg1 object obj;
  133.     { var reg2 uintL len = (uintL)TheBignum(obj)->length; # Anzahl Words
  134.       return
  135.         #if (intDsize==32)
  136.           misch(TheBignum(obj)->data[0], # MSD
  137.                 TheBignum(obj)->data[len-1]) # und LSD
  138.         #elif (intDsize==16) || (bn_minlength<4)
  139.           highlow32(TheBignum(obj)->data[0], # MSD
  140.                     TheBignum(obj)->data[len-1]) # und LSD
  141.         #else # (intDsize==8) && (bn_minlength>=4)
  142.           ( (((uint32)TheBignum(obj)->data[0]) << 24)
  143.            |(((uint32)TheBignum(obj)->data[1]) << 16)
  144.            |(((uint32)TheBignum(obj)->data[2]) << 8)
  145.            |((uint32)TheBignum(obj)->data[len-1])
  146.           )
  147.         #endif
  148.         + 2*len; # und LΣnge*2
  149.     }
  150.   # Short-Float: Interne ReprΣsentation
  151.   local uint32 hashcode_sfloat (object obj);
  152.   #if 0
  153.   local uint32 hashcode_sfloat(obj)
  154.     var reg1 object obj;
  155.     { return hashcode1(obj); }
  156.   #else
  157.   #define hashcode_sfloat(obj)  hashcode1(obj)
  158.   #endif
  159.   # Single-Float: 32 Bit
  160.   local uint32 hashcode_ffloat (object obj);
  161.   local uint32 hashcode_ffloat(obj)
  162.     var reg1 object obj;
  163.     { return ffloat_value(obj); }
  164.   # Double-Float: fⁿhrende 32 Bit
  165.   local uint32 hashcode_dfloat (object obj);
  166.   local uint32 hashcode_dfloat(obj)
  167.     var reg1 object obj;
  168.     {
  169.       #ifdef intQsize
  170.       return (uint32)(TheDfloat(obj)->float_value >> 32);
  171.       #else
  172.       return TheDfloat(obj)->float_value.semhi;
  173.       #endif
  174.     }
  175.   # Long-Float: Mischung aus Exponent, LΣnge, erste 32 Bit
  176.   extern uint32 hashcode_lfloat (object obj); # siehe LFLOAT.D
  177. # allgemein:
  178.   local uint32 hashcode2(obj)
  179.     var reg1 object obj;
  180.     { if (!numberp(obj)) # eine Zahl?
  181.         # nein -> EQ-Hashcode nehmen (bei Characters ist ja EQL == EQ) :
  182.         { return hashcode1(obj); }
  183.         # ja -> nach Typcode unterscheiden:
  184.         { switch (typecode(obj) & ~(bit(number_bit_t)|bit(sign_bit_t)))
  185.             { case fixnum_type & ~(bit(number_bit_t)|bit(sign_bit_t)): # Fixnum
  186.                 return hashcode_fixnum(obj);
  187.               case bignum_type & ~(bit(number_bit_t)|bit(sign_bit_t)): # Bignum
  188.                 return hashcode_bignum(obj);
  189.               case sfloat_type & ~(bit(number_bit_t)|bit(sign_bit_t)): # Short-Float
  190.                 return hashcode_sfloat(obj);
  191.               case ffloat_type & ~(bit(number_bit_t)|bit(sign_bit_t)): # Single-Float
  192.                 return hashcode_ffloat(obj);
  193.               case dfloat_type & ~(bit(number_bit_t)|bit(sign_bit_t)): # Double-Float
  194.                 return hashcode_dfloat(obj);
  195.               case lfloat_type & ~(bit(number_bit_t)|bit(sign_bit_t)): # Long-Float
  196.                 return hashcode_lfloat(obj);
  197.               case ratio_type & ~(bit(number_bit_t)|bit(sign_bit_t)): # Ratio
  198.                 # beide Komponenten hashen, mischen
  199.                 { var reg2 uint32 code1 = hashcode2(TheRatio(obj)->rt_num);
  200.                   var reg3 uint32 code2 = hashcode2(TheRatio(obj)->rt_den);
  201.                   return misch(code1,code2);
  202.                 }
  203.               case complex_type & ~(bit(number_bit_t)|bit(sign_bit_t)): # Complex
  204.                 # beide Komponenten hashen, mischen
  205.                 { var reg2 uint32 code1 = hashcode2(TheComplex(obj)->c_real);
  206.                   var reg3 uint32 code2 = hashcode2(TheComplex(obj)->c_imag);
  207.                   return misch(code1,code2);
  208.                 }
  209.               default: NOTREACHED
  210.         }   }
  211.     }
  212.  
  213. # UP: Berechnet den EQUAL-Hashcode eines Objekts.
  214. # hashcode3(obj)
  215. # Er ist nur bis zur nΣchsten GC oder der nΣchsten Modifizierung des Objekts
  216. # gⁿltig.
  217. # Aus (equal X Y) folgt (= (hashcode3 X) (hashcode3 Y)).
  218. # > obj: ein Objekt
  219. # < ergebnis: Hashcode, eine 32-Bit-Zahl
  220.   local uint32 hashcode3 (object obj);
  221. # Hilfsfunktionen bei bekanntem Typ:
  222.   # String -> LΣnge, erste max. 31 Zeichen, letztes Zeichen verwerten
  223.   local uint32 hashcode_string (object obj);
  224.   local uint32 hashcode_string(obj)
  225.     var reg5 object obj;
  226.     { var uintL len;
  227.       var reg1 uintB* ptr = unpack_string(obj,&len); # ab ptr kommen len Zeichen
  228.       var reg2 uint32 bish_code = 0x33DAE11FUL + len; # LΣnge verwerten
  229.       if (len > 0)
  230.         { bish_code ^= (uint32)(ptr[len-1]); # letztes Zeichen dazu
  231.          {var reg3 uintC count = (len <= 31 ? len : 31); # min(len,31)
  232.           dotimespC(count,count,
  233.             { var reg4 uint32 next_code = (uint32)(*ptr++); # nΣchstes Zeichen
  234.               bish_code = misch(bish_code,next_code); # dazunehmen
  235.             });
  236.         }}
  237.       return bish_code;
  238.     }
  239.   # Bit-Vektor -> LΣnge, erste 16 Bits, letzte 16 Bits verwerten
  240.   local uint32 hashcode_bvector (object obj);
  241.   local uint32 hashcode_bvector(obj)
  242.     var reg8 object obj;
  243.     { var reg6 uintL len = vector_length(obj); # LΣnge
  244.       var uintL index = 0;
  245.       var reg7 object sbv = array_displace_check(obj,len,&index);
  246.       # sbv der Datenvektor, index ist der Index in den Datenvektor.
  247.       if (!simple_bit_vector_p(sbv))
  248.         # Bei Byte-Vektoren schauen wir in deren Bitvektor hinein.
  249.         { len = len << (TheArray(sbv)->flags /* & arrayflags_atype_mask */ );
  250.           sbv = TheArray(sbv)->data;
  251.         }
  252.       #if BIG_ENDIAN_P && (Varobject_alignment%2 == 0)
  253.         # Bei Big-Endian-Maschinen kann man gleich mit 16 Bit auf einmal arbeiten
  254.         # (sofern Varobject_alignment durch 2 Byte teilbar ist):
  255.         #define bitpack  16
  256.         #define uint_bitpack  uint16
  257.         #define get32bits_at  highlow32_at
  258.       #else
  259.         # Sonst kann man nur 8 Bit auf einmal nehmen:
  260.         #define bitpack  8
  261.         #define uint_bitpack  uint8
  262.         #define get32bits_at(p) \
  263.           (((((((uint32)((p)[0])<<8)|(uint32)((p)[1]))<<8)|(uint32)((p)[2]))<<8)|(uint32)((p)[3]))
  264.       #endif
  265.      {var reg1 uint_bitpack* ptr = # Pointer aufs erste benutzte Word
  266.                (uint_bitpack*)(&TheSbvector(sbv)->data[0]) + floor(index,bitpack);
  267.       var reg5 uintL offset = index%bitpack; # Offset innerhalb des Word
  268.       if (len <= 32)
  269.         # LΣnge <= 32 -> alle Bits nehmen:
  270.         if (len == 0)
  271.           { return 0x8FA1D564UL; }
  272.           else
  273.           # 0<len<=32
  274.           { var reg4 uintL need = offset+len; # Brauche erstmal need Bits
  275.             # need < 48
  276.             var reg2 uint32 akku12 = 0; # 48-Bit-Akku, Teil 1 und 2
  277.             var reg3 uint32 akku3 = 0; # 48-Bit-Akku, Teil 3
  278.             #if (bitpack==16)
  279.             if (need > 0)
  280.               { akku12 = highlow32_0(*ptr++); # erste 16 Bits
  281.                 if (need > 16)
  282.                   { akku12 |= (uint32)(*ptr++); # nΣchste 16 Bits
  283.                     if (need > 32)
  284.                       { akku3 = (uint32)(*ptr++); # letzte 16 Bits
  285.               }   }   }
  286.             #endif
  287.             #if (bitpack==8)
  288.             if (need > 0)
  289.               { akku12 = (uint32)(*ptr++)<<24; # erste 8 Bits
  290.                 if (need > 8)
  291.                   { akku12 |= (uint32)(*ptr++)<<16; # nΣchste 8 Bits
  292.                     if (need > 16)
  293.                       { akku12 |= (uint32)(*ptr++)<<8; # nΣchste 8 Bits
  294.                         if (need > 24)
  295.                           { akku12 |= (uint32)(*ptr++); # nΣchste 8 Bits
  296.                             if (need > 32)
  297.                               { akku3 = (uint32)(*ptr++)<<8; # nΣchste 8 Bits
  298.                                 if (need > 40)
  299.                                   { akku3 |= (uint32)(*ptr++); # letzte 8 Bits
  300.               }   }   }   }   }   }
  301.             #endif
  302.             # need Bits in akku12,akku3 um offset Bits nach links schieben:
  303.             akku12 = (akku12 << offset) | (uint32)high16(akku3 << offset);
  304.             # 32 Bits in akku12 fertig.
  305.             # irrelevante Bits ausmaskieren:
  306.             akku12 = akku12 & ~(bit(32-len)-1);
  307.             # LΣnge verwerten:
  308.             return akku12+len;
  309.           }
  310.         else
  311.         # LΣnge > 32 -> erste und letzte 16 Bits nehmen:
  312.         { var reg2 uint32 akku12 = # 32-Bit-Akku
  313.             get32bits_at(ptr) << offset; # enthΣlt mind. die ersten 16 Bits
  314.           offset += len; # End-Offset des Bitvektor
  315.           ptr += floor(offset,bitpack); # zeigt aufs letzte benutzte Word
  316.           offset = offset%bitpack; # End-Offset innerhalb des Word
  317.          {var reg3 uint32 akku34 = # 32-Bit-Akku
  318.             get32bits_at(ptr-(16/bitpack)) << offset; # enthΣlt mind. die letzten 16 Bits
  319.           # erste 16, letzte 16 Bits herausgreifen und LΣnge verwerten:
  320.           return highlow32(high16(akku12),high16(akku34)) + len;
  321.         }}
  322.       #undef get32bits_at
  323.       #undef uint_bitpack
  324.       #undef bitpack
  325.     }}
  326.   # Atom -> Fallunterscheidung nach Typ
  327.   local uint32 hashcode_atom (object obj);
  328.   local uint32 hashcode_atom(obj)
  329.     var reg1 object obj;
  330.     { if (symbolp(obj)) # ein Symbol?
  331.         { return hashcode1(obj); } # ja -> EQ-Hashcode nehmen
  332.       elif (numberp(obj)) # eine Zahl?
  333.         { return hashcode2(obj); } # ja -> EQL-Hashcode nehmen
  334.       else
  335.         { var reg2 tint type = typecode(obj) & ~imm_array_mask # Typinfo
  336.                                & ~bit(notsimple_bit_t); # ob simple oder nicht, ist irrelevant
  337.           if (type == (sbvector_type & ~bit(notsimple_bit_t))) # Bit-Vektor ?
  338.             { return hashcode_bvector(obj); } # komponentenweise ansehen
  339.           if (type == (sstring_type & ~bit(notsimple_bit_t))) # String ?
  340.             { return hashcode_string(obj); } # komponentenweise ansehen
  341.           if (xpathnamep(obj))
  342.             # Pathname -> komponentenweise ansehen:
  343.             { check_SP();
  344.              {var reg4 uint32 bish_code = 0xB0DD939EUL;
  345.               var reg3 object* ptr = &((Record)ThePathname(obj))->recdata[0];
  346.               var reg6 uintC count;
  347.               dotimespC(count,ThePathname(obj)->reclength,
  348.                 { var reg5 uint32 next_code = hashcode3(*ptr++); # Hashcode der nΣchsten Komponente
  349.                   # Bei defined(PATHNAME_AMIGAOS) || defined(PATHNAME_OS2) den EQUALP-Hashcode nehmen??
  350.                   bish_code = misch(bish_code,next_code); # dazunehmen
  351.                 });
  352.               return bish_code;
  353.             }}
  354.           # sonst: EQ-Hashcode nehmen (bei Characters ist ja EQL == EQ)
  355.           return hashcode1(obj);
  356.     }   }
  357. # Cons -> Inhalt bis zur Tiefe 4 ansehen:
  358. # Jeweils Hashcode des CAR und Hashcode des CDR bestimmen
  359. # und geshiftet kombinieren. Als Shifts passen z.B. 16,7,5,3,
  360. # da {0,16} + {0,7} + {0,5} + {0,3} = {0,3,5,7,8,10,12,15,16,19,21,23,24,26,28,31}
  361. # aus 16 verschiedenen Elementen von {0,...,31} besteht.
  362.   # Objekt, bei Cons nur bis Tiefe 0
  363.   local uint32 hashcode_cons0 (object obj);
  364.   local uint32 hashcode_cons0(obj)
  365.     var reg1 object obj;
  366.     { if (atomp(obj))
  367.         { return hashcode_atom(obj); }
  368.         else
  369.         # Cons -> Hashcode := 1
  370.         { return 1; }
  371.     }
  372.   # Objekt, bei Cons nur bis Tiefe 1
  373.   local uint32 hashcode_cons1 (object obj);
  374.   local uint32 hashcode_cons1(obj)
  375.     var reg1 object obj;
  376.     { if (atomp(obj))
  377.         { return hashcode_atom(obj); }
  378.         else
  379.         # Cons -> Hashcode des CAR und des CDR bestimmen und mischen:
  380.         { var reg2 uint32 code1 = hashcode_cons0(Car(obj));
  381.           var reg3 uint32 code2 = hashcode_cons0(Cdr(obj));
  382.           return rotate_left(3,code1) ^ code2;
  383.     }   }
  384.   # Objekt, bei Cons nur bis Tiefe 2
  385.   local uint32 hashcode_cons2 (object obj);
  386.   local uint32 hashcode_cons2(obj)
  387.     var reg1 object obj;
  388.     { if (atomp(obj))
  389.         { return hashcode_atom(obj); }
  390.         else
  391.         # Cons -> Hashcode des CAR und des CDR bestimmen und mischen:
  392.         { var reg2 uint32 code1 = hashcode_cons1(Car(obj));
  393.           var reg3 uint32 code2 = hashcode_cons1(Cdr(obj));
  394.           return rotate_left(5,code1) ^ code2;
  395.     }   }
  396.   # Objekt, bei Cons nur bis Tiefe 3
  397.   local uint32 hashcode_cons3 (object obj);
  398.   local uint32 hashcode_cons3(obj)
  399.     var reg1 object obj;
  400.     { if (atomp(obj))
  401.         { return hashcode_atom(obj); }
  402.         else
  403.         # Cons -> Hashcode des CAR und des CDR bestimmen und mischen:
  404.         { var reg2 uint32 code1 = hashcode_cons2(Car(obj));
  405.           var reg3 uint32 code2 = hashcode_cons2(Cdr(obj));
  406.           return rotate_left(7,code1) ^ code2;
  407.     }   }
  408.   # Objekt, bei Cons nur bis Tiefe 4
  409.   local uint32 hashcode3(obj)
  410.     var reg1 object obj;
  411.     { if (atomp(obj))
  412.         { return hashcode_atom(obj); }
  413.         else
  414.         # Cons -> Hashcode des CAR und des CDR bestimmen und mischen:
  415.         { var reg2 uint32 code1 = hashcode_cons3(Car(obj));
  416.           var reg3 uint32 code2 = hashcode_cons3(Cdr(obj));
  417.           return rotate_left(16,code1) ^ code2;
  418.     }   }
  419.  
  420. # UP: Berechnet den Hashcode eines Objekts bezⁿglich einer Hashtabelle.
  421. # hashcode(ht,obj)
  422. # > ht: Hash-Table
  423. # > obj: Objekt
  424. # < ergebnis: Index in den Index-Vektor
  425.   local uintL hashcode (object ht, object obj);
  426.   local uintL hashcode(ht,obj)
  427.     var reg1 object ht;
  428.     var reg5 object obj;
  429.     { # Hashcode je nach Hashtabellen-Typ:
  430.       var reg2 uintB flags = TheHashtable(ht)->recflags;
  431.       var reg3 uint32 code =
  432.         (flags & bit(0) ? hashcode1(obj) : # EQ-Hashcode
  433.          flags & bit(1) ? hashcode2(obj) : # EQL-Hashcode
  434.          flags & bit(2) ? hashcode3(obj) : # EQUAL-Hashcode
  435.          0 /*NOTREACHED*/
  436.         );
  437.       # dann durch SIZE dividieren:
  438.       var reg4 uint32 rest;
  439.       divu_3232_3232(code,posfixnum_to_L(TheHashtable(ht)->ht_size),,rest = );
  440.       return rest;
  441.     }
  442.  
  443. # UP: Reorganisiert eine Hash-Tabelle, nachdem durch eine GC die Hashcodes
  444. # der Keys verΣndert wurden.
  445. # rehash(ht);
  446. # > ht: Hash-Table
  447.   local void rehash (object ht);
  448.   local void rehash(ht)
  449.     var reg9 object ht;
  450.     { # Index-Vektor mit "nix" fⁿllen:
  451.       var reg2 object Ivektor = TheHashtable(ht)->ht_itable; # Index-Vektor
  452.       { var reg1 object* ptr = &TheSvector(Ivektor)->data[0];
  453.         var reg3 uintL count = posfixnum_to_L(TheHashtable(ht)->ht_size); # SIZE, >0
  454.         dotimespL(count,count, { *ptr++ = nix; } );
  455.       }
  456.       # "Listen"struktur elementweise aufbauen:
  457.      {var reg9 object Nvektor = TheHashtable(ht)->ht_ntable; # Next-Vektor
  458.       var reg9 object KVvektor = TheHashtable(ht)->ht_kvtable; # Key-Value-Vektor
  459.       var reg5 object index = TheHashtable(ht)->ht_maxcount; # MAXCOUNT
  460.       var reg9 uintL maxcount = posfixnum_to_L(index);
  461.       var reg3 object* Nptr = &TheSvector(Nvektor)->data[maxcount];
  462.       var reg4 object* KVptr = &TheSvector(KVvektor)->data[2*maxcount];
  463.       var reg8 object freelist = nix;
  464.       var reg7 object count = Fixnum_0;
  465.       loop
  466.         # Schleife, lΣuft durch den Key-Value-Vektor und den Next-Vektor.
  467.         # index = MAXCOUNT,...,0 (Fixnum),
  468.         # Nptr = &TheSvector(Nptr)->data[index],
  469.         # KVptr = &TheSvector(KVptr)->data[index],
  470.         # freelist = bisherige Freiliste,
  471.         # count = Paare-ZΣhler als Fixnum.
  472.         { if (eq(index,Fixnum_0)) break; # index=0 -> Schleife fertig
  473.           index = fixnum_inc(index,-1); # index decrementieren
  474.           KVptr -= 2;
  475.          {var reg6 object key = KVptr[0]; # nΣchster Key
  476.           if (!eq(key,leer)) # /= "leer" ?
  477.             { var reg3 uintL hashindex = hashcode(ht,key); # Hashcode dazu
  478.               # "Liste", die bei Eintrag hashindex anfΣngt, um index erweitern:
  479.               # Eintrag im Index-Vektor in den Next-Vektor kopieren
  480.               # und durch index (ein Pointer auf diese Stelle) ersetzen:
  481.               var reg1 object* Iptr = &TheSvector(Ivektor)->data[hashindex];
  482.               *--Nptr = *Iptr; # Eintrag in den Next-Vektor kopieren
  483.               *Iptr = index; # und durch Zeiger darauf ersetzen
  484.               count = fixnum_inc(count,1); # mitzΣhlen
  485.             }
  486.             else
  487.             # Freiliste im Next-Vektor verlΣngern:
  488.             { *--Nptr = freelist; freelist = index; }
  489.         }}
  490.       TheHashtable(ht)->ht_freelist = freelist; # Freiliste abspeichern
  491.       TheHashtable(ht)->ht_count = count; # Paare-Zahl abspeichern (konsistenzhalber)
  492.       mark_ht_valid(TheHashtable(ht)); # Hashtabelle ist nun fertig organisiert
  493.     }}
  494.  
  495. # UP: Sucht ein Key in einer Hash-Tabelle.
  496. # hash_lookup(ht,obj,&KVptr,&Nptr,&Iptr)
  497. # > ht: Hash-Tabelle
  498. # > obj: Objekt
  499. # < falls gefunden: ergebnis=TRUE,
  500. #     KVptr[0], KVptr[1] : Key, Value im Key-Value-Vektor,
  501. #     *Nptr : zugeh÷riger Eintrag im Next-Vektor,
  502. #     *Iptr : auf *Nptr zeigender vorheriger Index
  503. # < falls nicht gefunden: ergebnis=FALSE,
  504. #     *Iptr : zum Key geh÷riger Eintrag im Index-Vektor
  505. #             oder ein beliebiges Element der dort beginnenden "Liste"
  506.   local boolean hash_lookup (object ht, object obj, object** KVptr_, object** Nptr_, object** Iptr_);
  507.   local boolean hash_lookup(ht,obj,KVptr_,Nptr_,Iptr_)
  508.     var reg1 object ht;
  509.     var reg7 object obj;
  510.     var reg10 object** KVptr_;
  511.     var reg10 object** Nptr_;
  512.     var reg10 object** Iptr_;
  513.     { var reg4 uintB flags = TheHashtable(ht)->recflags;
  514.       if (!ht_validp(TheHashtable(ht)))
  515.         # Hash-Tabelle mu▀ erst noch reorganisiert werden
  516.         { rehash(ht); }
  517.      {var reg9 uintL hashindex = hashcode(ht,obj); # Hashcode berechnen
  518.       var reg2 object* Nptr = # Pointer auf den aktuellen Eintrag
  519.         &TheSvector(TheHashtable(ht)->ht_itable)->data[hashindex];
  520.       loop
  521.         { # "Liste" weiterverfolgen:
  522.           if (eq(*Nptr,nix)) break; # "Liste" zu Ende -> nicht gefunden
  523.           { var reg3 uintL index = posfixnum_to_L(*Nptr); # nΣchster Index
  524.             var reg8 object* Iptr = Nptr;
  525.             Nptr = # Pointer auf Eintrag im Next-Vektor
  526.               &TheSvector(TheHashtable(ht)->ht_ntable)->data[index];
  527.            {var reg5 object* KVptr = # Pointer auf EintrΣge im Key-Value-Vektor
  528.               &TheSvector(TheHashtable(ht)->ht_kvtable)->data[2*index];
  529.             var reg6 object key = KVptr[0];
  530.             # key mit obj vergleichen:
  531.             if (flags & bit(0) ? eq(key,obj) : # mit EQ vergleichen
  532.                 flags & bit(1) ? eql(key,obj) : # mit EQL vergleichen
  533.                 flags & bit(2) ? equal(key,obj) : # mit EQUAL vergleichen
  534.                 FALSE
  535.                )
  536.               # Objekt obj gefunden
  537.               { *KVptr_ = KVptr; *Nptr_ = Nptr; *Iptr_ = Iptr; return TRUE; }
  538.         } }}
  539.       # nicht gefunden
  540.       *Iptr_ = Nptr; return FALSE;
  541.     }}
  542.  
  543. # Macro: TrΣgt ein Key-Value-Paar in einer Hash-Tabelle ein.
  544. # hash_store(key,value);
  545. # > object ht: Hash-Tabelle
  546. # > object freelist: Anfang der Freiliste im Next-Vektor, /= nix
  547. # > key: Key
  548. # > value: Value
  549. # > object* Iptr: beliebiges Element der "Liste", die zu Key geh÷rt
  550.   #define hash_store(key,value)  \
  551.     { var reg6 uintL index = posfixnum_to_L(freelist); # freier Index          \
  552.       var reg5 object* Nptr = # Adresse des freien Eintrags im Next-Vektor       \
  553.         &TheSvector(TheHashtable(ht)->ht_ntable)->data[index];                 \
  554.       var reg4 object* KVptr = # Adresse der freien EintrΣge im Key-Value-Vektor \
  555.         &TheSvector(TheHashtable(ht)->ht_kvtable)->data[2*index];              \
  556.       set_break_sem_2(); # Vor Unterbrechungen schⁿtzen                        \
  557.       # COUNT incrementieren:                                                  \
  558.       TheHashtable(ht)->ht_count = fixnum_inc(TheHashtable(ht)->ht_count,1);   \
  559.       # Freiliste verkⁿrzen:                                                   \
  560.       TheHashtable(ht)->ht_freelist = *Nptr;                                   \
  561.       # Key und Value abspeichern:                                             \
  562.       *KVptr++ = key; *KVptr++ = value;                                        \
  563.       # freies Listenelement index in die "Liste" einfⁿgen                     \
  564.       # (nach resize an den Listenanfang, da Iptr in den Index-Vektor zeigt,   \
  565.       # sonst ans Listenende, da hash_lookup mit *Iptr=nix beendet wurde):     \
  566.       *Nptr = *Iptr; *Iptr = freelist;                                         \
  567.       clr_break_sem_2(); # Unterbrechungen wieder zulassen                     \
  568.     }
  569.  
  570. # UP: Stellt die Zahlen und Vektoren fⁿr eine neue Hash-Tabelle bereit.
  571. # prepare_resize(maxcount,mincount_threshold)
  572. # > maxcount: gewⁿnschte neue Gr÷▀e MAXCOUNT
  573. # > mincount_threshold: Short-Float MINCOUNT-THRESHOLD
  574. # < ergebnis: maxcount
  575. # < Stackaufbau: MAXCOUNT, SIZE, MINCOUNT,
  576. #                Index-Vektor, Next-Vektor, Key-Value-Vektor.
  577. # Erniedrigt STACK um 6
  578. # kann GC ausl÷sen
  579.   local uintL prepare_resize (object maxcount, object mincount_threshold);
  580.   local uintL prepare_resize(maxcount,mincount_threshold)
  581.     var reg3 object maxcount;
  582.     var reg4 object mincount_threshold;
  583.     { # ▄berprⁿfe, ob maxcount ein nicht zu gro▀es Fixnum >0 ist:
  584.       if (!posfixnump(maxcount)) goto fehler_maxcount;
  585.      {var reg1 uintL maxcountL = posfixnum_to_L(maxcount);
  586.       var reg2 uintL sizeL = 2*maxcountL+1;
  587.       # SIZE ungerade, damit die Hashfunktion besser wird!
  588.       if (!(sizeL <= (uintL)(bitm(oint_data_len)-1))) # sizeL sollte in ein Fixnum passen
  589.         goto fehler_maxcount;
  590.       # Zahlen auf den Stack:
  591.       pushSTACK(maxcount); # MAXCOUNT
  592.       pushSTACK(fixnum(sizeL)); # SIZE
  593.       { # MINCOUNT := (floor (* maxcount mincount-threshold))
  594.         pushSTACK(maxcount); pushSTACK(mincount_threshold); funcall(L(mal),2);
  595.         pushSTACK(value1); funcall(L(floor),1);
  596.         pushSTACK(value1);
  597.       }
  598.       # Stackaufbau: MAXCOUNT, SIZE, MINCOUNT.
  599.       # neue Vektoren allozieren:
  600.       pushSTACK(allocate_vector(sizeL)); # Index-Vektor beschaffen
  601.       pushSTACK(allocate_vector(maxcountL)); # Next-Vektor beschaffen
  602.       pushSTACK(allocate_vector(2*maxcountL)); # Key-Value-Vektor beschaffen
  603.       # fertig.
  604.       return maxcountL;
  605.      }
  606.       fehler_maxcount: # maxcount kein Fixnum oder zu gro▀
  607.         pushSTACK(maxcount); # Wert fⁿr Slot DATUM von TYPE-ERROR
  608.         pushSTACK(O(type_hashtable_size)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  609.         pushSTACK(maxcount);
  610.         fehler(type_error,
  611.                DEUTSCH ? "Zu gro▀e Hashtabellengr÷▀e ~" :
  612.                ENGLISH ? "Hash table size ~ too large" :
  613.                FRANCAIS ? "La taille ~ est trop grande pour une table de hachage." :
  614.                ""
  615.               );
  616.     }
  617.  
  618. # UP: Vergr÷▀ert oder verkleinert eine Hash-Tabelle
  619. # resize(ht,maxcount)
  620. # > ht: Hash-Table
  621. # > maxcount: gewⁿnschte neue Gr÷▀e MAXCOUNT
  622. # < ergebnis: Hash-Table, EQ zur alten
  623. # kann GC ausl÷sen
  624.   local object resize (object ht, object maxcount);
  625.   local object resize(ht,maxcount)
  626.     var reg8 object ht;
  627.     var reg9 object maxcount;
  628.     { pushSTACK(ht);
  629.      {var reg9 uintL maxcountL =
  630.         prepare_resize(maxcount,TheHashtable(ht)->ht_mincount_threshold);
  631.       # Ab jetzt keine GC mehr!
  632.       var reg9 object KVvektor = popSTACK(); # neuer Key-Value-Vektor
  633.       var reg10 object Nvektor = popSTACK(); # Next-Vektor
  634.       var reg10 object Ivektor = popSTACK(); # Index-Vektor
  635.       var reg10 object mincount = popSTACK(); # MINCOUNT
  636.       var reg10 object size = popSTACK(); # SIZE
  637.       maxcount = popSTACK();
  638.       ht = popSTACK();
  639.       # Neuen Key-Value-Vektor fⁿllen:
  640.       # Durch den alten Key-Value-Vektor durchlaufen und
  641.       # alle Key-Value-Paare mit Key /= "leer" kopieren:
  642.       { # Zum Durchlaufen des alten Key-Value-Vektors:
  643.         var reg3 uintL oldcount = posfixnum_to_L(TheHashtable(ht)->ht_maxcount);
  644.         var reg1 object* oldKVptr = &TheSvector(TheHashtable(ht)->ht_kvtable)->data[0];
  645.         # Zum Durchlaufen des neuen Key-Value-Vektors:
  646.         var reg4 uintL count = maxcountL;
  647.         var reg2 object* KVptr = &TheSvector(KVvektor)->data[0];
  648.         # Zum MitzΣhlen:
  649.         var reg7 object counter = Fixnum_0;
  650.         dotimesL(oldcount,oldcount,
  651.           { var reg5 object nextkey = *oldKVptr++; # nΣchster Key
  652.             var reg6 object nextvalue = *oldKVptr++; # und Value
  653.             if (!eq(nextkey,leer))
  654.               # Eintrag in den neuen Key-Value-Vektor ⁿbernehmen:
  655.               { if (count==0) # Ist der neue Vektor schon voll?
  656.                   # Der Platz reicht nicht!!
  657.                   { pushSTACK(ht); # Hash-Table
  658.                     fehler(serious_condition,
  659.                            DEUTSCH ? "Interner Fehler beim Reorganisieren von ~." :
  660.                            ENGLISH ? "internal error occured while resizing ~" :
  661.                            FRANCAIS ? "Une erreur interne s'est produite au moment de la rΘorganisation de ~." :
  662.                            ""
  663.                           );
  664.                   }
  665.                 count--;
  666.                 *KVptr++ = nextkey; *KVptr++ = nextvalue; # im neuen Vektor ablegen
  667.                 counter = fixnum_inc(counter,1); # und mitzΣhlen
  668.               }
  669.           });
  670.         # Noch count Paare des neuen Key-Value-Vektors als "leer" markieren:
  671.         dotimesL(count,count, { *KVptr++ = leer; *KVptr++ = leer; } );
  672.         # Hash-Tabelle modifizieren:
  673.         set_break_sem_2(); # Vor Unterbrechungen schⁿtzen
  674.         mark_ht_invalid(TheHashtable(ht)); # Tabelle mu▀ erst noch reorganisiert werden
  675.         TheHashtable(ht)->ht_size = size; # neues SIZE eintragen
  676.         TheHashtable(ht)->ht_itable = Ivektor; # neuen Index-Vektor eintragen
  677.         TheHashtable(ht)->ht_maxcount = maxcount; # neues MAXCOUNT eintragen
  678.         TheHashtable(ht)->ht_freelist = nix; # Dummy als Freiliste
  679.         TheHashtable(ht)->ht_ntable = Nvektor; # neuen Next-Vektor eintragen
  680.         TheHashtable(ht)->ht_kvtable = KVvektor; # neuen Key-Value-Vektor eintragen
  681.         TheHashtable(ht)->ht_count = counter; # COUNT eintragen (konsistenzhalber)
  682.         TheHashtable(ht)->ht_mincount = mincount; # neues MINCOUNT eintragen
  683.         clr_break_sem_2(); # Unterbrechungen wieder zulassen
  684.         return ht;
  685.     }}}
  686.  
  687. # Macro: Vergr÷▀ert eine Hash-Tabelle so lange, bis freelist /= nix
  688. # hash_prepare_store();
  689. # > object key: Key (im Stack)
  690. # > object ht: Hash-Tabelle
  691. # < object ht: Hash-Tabelle
  692. # < object freelist: Anfang der Freiliste im Next-Vektor, /= nix
  693. # < object* Iptr: beliebiges Element der "Liste", die zu Key geh÷rt
  694. # kann GC ausl÷sen
  695.   #define hash_prepare_store(key)  \
  696.     { retry:                                                                    \
  697.       freelist = TheHashtable(ht)->ht_freelist;                                 \
  698.       if (eq(freelist,nix)) # Freiliste = leere "Liste" ?                       \
  699.         # ja -> mu▀ die Hash-Tabelle vergr÷▀ern:                                \
  700.         { pushSTACK(ht); # Hashtable retten                                     \
  701.           # neues maxcount ausrechnen:                                          \
  702.           pushSTACK(TheHashtable(ht)->ht_maxcount);                             \
  703.           pushSTACK(TheHashtable(ht)->ht_rehash_size); # REHASH-SIZE (>1)       \
  704.           funcall(L(mal),2); # (* maxcount rehash-size), ist > maxcount         \
  705.           pushSTACK(value1);                                                    \
  706.           funcall(L(ceiling),1); # (ceiling ...), Integer > maxcount            \
  707.           ht = resize(popSTACK(),value1); # Tabelle vergr÷▀ern                  \
  708.           rehash(ht); # und reorganisieren                                      \
  709.           # Adresse des Eintrags im Index-Vektor neu ausrechnen:                \
  710.          {var reg3 uintL hashindex = hashcode(ht,key); # Hashcode berechnen     \
  711.           Iptr = &TheSvector(TheHashtable(ht)->ht_itable)->data[hashindex];     \
  712.           goto retry;                                                           \
  713.         }}                                                                      \
  714.     }
  715.  
  716. # UP: L÷scht den Inhalt einer Hash-Tabelle.
  717. # clrhash(ht);
  718. # > ht: Hash-Tabelle
  719.   local void clrhash (object ht);
  720.   local void clrhash(ht)
  721.     var reg3 object ht;
  722.     { set_break_sem_2(); # Vor Unterbrechungen schⁿtzen
  723.       {var reg1 object* KVptr = &TheSvector(TheHashtable(ht)->ht_kvtable)->data[0];
  724.        var reg2 uintL count = posfixnum_to_L(TheHashtable(ht)->ht_maxcount);
  725.        dotimesL(count,count, # in jedem Eintrag
  726.          { *KVptr++ = leer; *KVptr++ = leer; # Key und Value leeren
  727.          });
  728.       }
  729.       TheHashtable(ht)->ht_count = Fixnum_0; # COUNT := 0
  730.       mark_ht_invalid(TheHashtable(ht)); # Hashtabelle spΣter noch reorganisieren
  731.       clr_break_sem_2(); # Unterbrechungen wieder zulassen
  732.     }
  733.  
  734. # (MAKE-HASH-TABLE [:test] [:size] [:rehash-size] [:rehash-threshold]
  735. #                  [:initial-contents]), CLTL S. 283
  736. LISPFUN(make_hash_table,0,0,norest,key,5,\
  737.         (kw(initial_contents),\
  738.          kw(test),kw(size),kw(rehash_size),kw(rehash_threshold)) )
  739.   { # Dem Rehash-Threshold entspricht in unserer Implementation das
  740.     # VerhΣltnis MAXCOUNT : SIZE = ca. 1 : 2.
  741.     # Wir ignorieren das rehash-threshold-Argument, da sowohl zu gro▀e als
  742.     # auch zu kleine Werte davon schΣdlich wΣren: 0.99 bewirkt im Durchschnitt
  743.     # zu lange Zugriffszeiten; 0.00001 bewirkt, da▀ SIZE = MAXCOUNT/threshold
  744.     # zu schnell ein Bignum werden k÷nnte.
  745.     # Das zusΣtzliche initial-contents-Argument ist eine Aliste = Liste von
  746.     # (Key . Value) - Paaren, mit denen die Tabelle initialisiert wird.
  747.     # Stackaufbau: initial-contents, test, size, rehash-size, rehash-threshold.
  748.     var reg3 uintB flags;
  749.     # test-Argument ⁿberprⁿfen:
  750.     { var reg1 object test = STACK_3;
  751.       if (eq(test,unbound))
  752.         { flags = bit(1); } # EQL als Default
  753.       elif (eq(test,S(eq)) || eq(test,L(eq)))
  754.         { flags = bit(0); } # EQ
  755.       elif (eq(test,S(eql)) || eq(test,L(eql)))
  756.         { flags = bit(1); } # EQL
  757.       elif (eq(test,S(equal)) || eq(test,L(equal)))
  758.         { flags = bit(2); } # EQUAL
  759.       else
  760.         { pushSTACK(test); # Wert fⁿr Slot DATUM von TYPE-ERROR
  761.           pushSTACK(O(type_hashtable_test)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  762.           pushSTACK(test);
  763.           pushSTACK(S(make_hash_table));
  764.           fehler(type_error,
  765.                  DEUTSCH ? "~: UnzulΣssiges :TEST-Argument ~" :
  766.                  ENGLISH ? "~: illegal :TEST argument ~" :
  767.                  FRANCAIS ? "~: Argument pour :TEST illicite : ~" :
  768.                  ""
  769.                 );
  770.     }   }
  771.     # flags enthΣlt die Flags zum Test.
  772.     # size-Argument ⁿberprⁿfen:
  773.     { var reg1 object size = STACK_2;
  774.       if (eq(size,unbound))
  775.         { STACK_2 = Fixnum_1; } # 1 als Default
  776.         else
  777.         { if (!posfixnump(size))
  778.             { pushSTACK(size); # Wert fⁿr Slot DATUM von TYPE-ERROR
  779.               pushSTACK(O(type_posfixnum)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  780.               pushSTACK(size);
  781.               pushSTACK(S(make_hash_table));
  782.               fehler(type_error,
  783.                      DEUTSCH ? "~: :SIZE-Argument sollte ein Fixnum >=0 sein, nicht ~" :
  784.                      ENGLISH ? "~: :SIZE argument should be a fixnum >=0, not ~" :
  785.                      FRANCAIS ? "~: L'argument :SIZE doit Ωtre de type FIXNUM positif ou zΘro et non ~." :
  786.                      ""
  787.                     );
  788.             }
  789.           # size ist ein Fixnum >=0
  790.           if (eq(size,Fixnum_0)) { STACK_2 = Fixnum_1; } # aus 0 mache 1
  791.     }   }
  792.     # size ist jetzt ein Fixnum >0.
  793.     # rehash-size ⁿberprⁿfen:
  794.     { if (eq(STACK_1,unbound))
  795.         # Default-Rehash-Size = 1.5s0
  796.         { STACK_1 = make_SF(0,SF_exp_mid+1,(bit(SF_mant_len)*3)/2); }
  797.         else
  798.         { if (!mfloatp(STACK_1)) # Float ist OK
  799.             { if (!mposfixnump(STACK_1)) # sonst sollte es ein Fixnum >=0 sein
  800.                 { fehler_rehash_size:
  801.                   pushSTACK(STACK_1); # Wert fⁿr Slot DATUM von TYPE-ERROR
  802.                   pushSTACK(O(type_hashtable_rehash_size)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  803.                   pushSTACK(STACK_(1+2));
  804.                   pushSTACK(S(make_hash_table));
  805.                   fehler(type_error,
  806.                          DEUTSCH ? "~: :REHASH-SIZE-Argument sollte ein Float > 1 sein, nicht ~" :
  807.                          ENGLISH ? "~: :REHASH-SIZE argument should be a float > 1, not ~" :
  808.                          FRANCAIS ? "~: L'argument :REHASH-SIZE devrait Ωtre un nombre α virgule flottante supΘrieur α 1 et non ~." :
  809.                          ""
  810.                         );
  811.                 }
  812.               # Da es sinnlos ist, eine Tabelle immer nur um eine feste
  813.               # Anzahl von Elementen gr÷▀er zu machen (fⁿhrt zu katastrophaler
  814.               # Effizienz), wird rehash-size := min(1 + rehash-size/size , 2.0)
  815.               # gesetzt.
  816.               pushSTACK(STACK_1); # rehash-size
  817.               pushSTACK(STACK_(2+1)); # size
  818.               funcall(L(durch),2); # (/ rehash-size size)
  819.               pushSTACK(value1);
  820.               funcall(L(einsplus),1); # (1+ ...)
  821.               pushSTACK(value1);
  822.               pushSTACK(make_SF(0,SF_exp_mid+2,bit(SF_mant_len))); # 2.0s0
  823.               funcall(L(min),2); # (MIN ... 2.0s0)
  824.               STACK_1 = value1; # =: rehash-size
  825.             }
  826.           # (> rehash-size 1) ⁿberprⁿfen:
  827.           pushSTACK(STACK_1); # rehash-size
  828.           pushSTACK(Fixnum_1); # 1
  829.           funcall(L(groesser),2); # (> rehash-size 1)
  830.           if (nullp(value1)) goto fehler_rehash_size;
  831.           # rehash-size in ein Short-Float umwandeln:
  832.           pushSTACK(STACK_1); # rehash-size
  833.           pushSTACK(SF_0); # 0.0s0
  834.           funcall(L(float),2); # (FLOAT rehash-size 0.0s0) = (COERCE rehash-size 'SHORT-FLOAT)
  835.           # (>= rehash-size 1.125s0) erzwingen:
  836.           pushSTACK(value1);
  837.           pushSTACK(make_SF(0,SF_exp_mid+1,(bit(SF_mant_len)/8)*9)); # 1.125s0
  838.           funcall(L(max),2); # (max rehash-size 1.125s0)
  839.           STACK_1 = value1; # =: rehash-size
  840.     }   }
  841.     # rehash-size ist ein Short-Float >= 1.125 .
  842.     # rehash-threshold ⁿberprⁿfen: sollte ein Float >=0, <=1 sein
  843.     { var reg1 object rehash_threshold = STACK_0;
  844.       if (!eq(rehash_threshold,unbound)) # nicht angegeben -> OK
  845.         { if (!floatp(rehash_threshold))
  846.             { fehler_rehash_threshold:
  847.               # Argument bereits in STACK_0, Wert fⁿr Slot DATUM von TYPE-ERROR
  848.               pushSTACK(O(type_hashtable_rehash_threshold)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  849.               pushSTACK(STACK_1);
  850.               pushSTACK(S(make_hash_table));
  851.               fehler(type_error,
  852.                      DEUTSCH ? "~: :REHASH-THRESHOLD-Argument sollte ein Float zwischen 0 und 1 sein, nicht ~" :
  853.                      ENGLISH ? "~: :REHASH-THRESHOLD argument should be a float between 0 and 1, not ~" :
  854.                      FRANCAIS ? "~: L'argument :REHASH-THRESHOLD devrait Ωtre un nombre α virgule flottante compris entre 0 et 1 et non ~." :
  855.                      ""
  856.                     );
  857.             }
  858.           pushSTACK(Fixnum_1);
  859.           pushSTACK(rehash_threshold);
  860.           pushSTACK(Fixnum_0);
  861.           funcall(L(grgleich),3); # (>= 1 rehash-threshold 0)
  862.           if (nullp(value1)) goto fehler_rehash_threshold;
  863.     }   }
  864.     # Nun sind alle Argumente ⁿberprⁿft.
  865.     # Ist das initial-contents-Argument angegeben, so wird
  866.     # size := (max size (length initial-contents)) gesetzt, damit nachher beim
  867.     # Eintragen des initial-contents die Tabelle nicht vergr÷▀ert werden mu▀:
  868.     { var reg1 object initial_contents = STACK_4;
  869.       if (!eq(initial_contents,unbound)) # angegeben ?
  870.         { var reg1 uintL initial_length = llength(initial_contents); # LΣnge der Aliste
  871.           if (initial_length > posfixnum_to_L(STACK_2)) # > size ?
  872.             { STACK_2 = fixnum(initial_length); } # ja -> size vergr÷▀ern
  873.     }   }
  874.     # size ist ein Fixnum >0, >= (length initial-contents) .
  875.     # MINCOUNT-THRESHOLD = 1/rehash-size^2 errechnen:
  876.     { var reg1 object rehash_size = STACK_1;
  877.       pushSTACK(rehash_size);
  878.       pushSTACK(rehash_size);
  879.       funcall(L(mal),2); # (* rehash-size rehash-size)
  880.       pushSTACK(value1);
  881.       funcall(L(durch),1); # (/ ...)
  882.       STACK_0 = value1;
  883.     }
  884.     # Stackaufbau: initial-contents, test, size, rehash-size, mincount-threshold.
  885.     # Vektoren beschaffen usw., mit size als MAXCOUNT:
  886.     prepare_resize(STACK_2,STACK_0);
  887.     { var reg1 object ht = allocate_hash_table(); # neue Hash-Tabelle
  888.       # fⁿllen:
  889.       TheHashtable(ht)->ht_kvtable = popSTACK(); # Key-Value-Vektor
  890.       TheHashtable(ht)->ht_ntable = popSTACK(); # Next-Vektor
  891.       TheHashtable(ht)->ht_itable = popSTACK(); # Index-Vektor
  892.       TheHashtable(ht)->ht_mincount = popSTACK(); # MINCOUNT
  893.       TheHashtable(ht)->ht_size = popSTACK(); # SIZE
  894.       TheHashtable(ht)->ht_maxcount = popSTACK(); # MAXCOUNT
  895.       # Stackaufbau: initial-contents, test, size, rehash-size, mincount-threshold.
  896.       TheHashtable(ht)->ht_mincount_threshold = popSTACK(); # MINCOUNT-THRESHOLD
  897.       TheHashtable(ht)->ht_rehash_size = popSTACK(); # REHASH-SIZE
  898.       TheHashtable(ht)->ht_freelist = nix; # Dummy als Freiliste
  899.       TheHashtable(ht)->recflags = flags;
  900.       clrhash(ht); # Tabelle leeren, COUNT := 0
  901.       skipSTACK(2);
  902.       # Stackaufbau: initial-contents.
  903.       { var reg2 object alist = popSTACK(); # initial-contents
  904.         while (consp(alist)) # Wenn es angegeben war, solange es ein Cons ist:
  905.           { var reg3 object next = Car(alist); # Alistenelement
  906.             if (consp(next)) # ein Cons (Key . Value) ?
  907.               # (SYSTEM::PUTHASH (car next) hashtable (cdr next)) ausfⁿhren,
  908.               # wobei die Tabelle nicht wachsen kann:
  909.               { var reg8 object key = Car(next);
  910.                 var object* KVptr;
  911.                 var object* Nptr;
  912.                 var object* Iptr;
  913.                 if (hash_lookup(ht,key,&KVptr,&Nptr,&Iptr)) # in der Hash-Tabelle suchen
  914.                   # schon gefunden -> war in der Aliste weiter links schon
  915.                   # enthalten, und in Alisten verdeckt die erste Assoziation
  916.                   # (links) alle anderen Assoziationen zum selben Key.
  917.                   {}
  918.                   else
  919.                   # nicht gefunden -> neuen Eintrag basteln:
  920.                   { var reg7 object freelist = # Anfang der Freiliste im Next-Vektor
  921.                       TheHashtable(ht)->ht_freelist;
  922.                     if (eq(freelist,nix)) # leere "Liste" ?
  923.                       { pushSTACK(ht); # Hash-Tabelle
  924.                         pushSTACK(S(make_hash_table));
  925.                         fehler(serious_condition,
  926.                                DEUTSCH ? "~: Interner Fehler beim Aufbauen von ~" :
  927.                                ENGLISH ? "~: internal error while building ~" :
  928.                                FRANCAIS ? "~: Une erreur interne s'est produite lors de la construction de ~." :
  929.                                ""
  930.                               );
  931.                       }
  932.                     hash_store(key,Cdr(next)); # Eintrag basteln
  933.               }   }
  934.             alist = Cdr(alist);
  935.           }
  936.       }
  937.       value1 = ht; mv_count=1; # Hash-Tabelle als Wert
  938.   } }
  939.  
  940. # UP: Sucht ein Objekt in einer Hash-Tabelle.
  941. # gethash(obj,ht)
  942. # > obj: Objekt, als Key
  943. # > ht: Hash-Tabelle
  944. # < ergebnis: zugeh÷riger Value, falls gefunden, nullobj sonst
  945.   global object gethash (object obj, object ht);
  946.   global object gethash(obj,ht)
  947.     var reg2 object obj;
  948.     var reg1 object ht;
  949.     { var object* KVptr;
  950.       var object* Nptr;
  951.       var object* Iptr;
  952.       if (hash_lookup(ht,obj,&KVptr,&Nptr,&Iptr))
  953.         { return KVptr[1]; } # gefunden -> Value
  954.         else
  955.         { return nullobj; }
  956.     }
  957.  
  958. # Fehler, wenn ein Argument keine Hash-Table ist
  959. # fehler_hashtable(obj);
  960. # > obj: Objekt
  961. # > subr_self: Aufrufer (ein SUBR)
  962.   nonreturning_function(local, fehler_hashtable, (object obj));
  963.   local void fehler_hashtable(obj)
  964.     var reg1 object obj;
  965.     { pushSTACK(obj); # Wert fⁿr Slot DATUM von TYPE-ERROR
  966.       pushSTACK(S(hash_table)); # Wert fⁿr Slot EXPECTED-TYPE von TYPE-ERROR
  967.       pushSTACK(obj);
  968.       pushSTACK(TheSubr(subr_self)->name);
  969.       fehler(type_error,
  970.              DEUTSCH ? "~: Argument ~ ist keine Hash-Table." :
  971.              ENGLISH ? "~: argument ~ is not a hash-table" :
  972.              FRANCAIS ? "~: L'argument ~ n'est pas une table de hachage." :
  973.              ""
  974.             );
  975.     }
  976.  
  977. # (GETHASH key hashtable [default]), CLTL S. 284
  978. LISPFUN(gethash,2,1,norest,nokey,0,NIL)
  979.   { var reg1 object ht = STACK_1; # hashtable-Argument
  980.     if (!hash_table_p(ht)) { fehler_hashtable(ht); } # ⁿberprⁿfen
  981.    {var object* KVptr;
  982.     var object* Nptr;
  983.     var object* Iptr;
  984.     # Key STACK_2 in der Hash-Tabelle suchen:
  985.     if (hash_lookup(ht,STACK_2,&KVptr,&Nptr,&Iptr))
  986.       # gefunden -> Value als Wert:
  987.       { value1 = KVptr[1]; value2 = T; mv_count=2; # und T als 2. Wert
  988.         skipSTACK(3);
  989.       }
  990.       else
  991.       # nicht gefunden -> default oder NIL als Wert
  992.       { var reg2 object def = popSTACK(); # default
  993.         value1 = (eq(def,unbound) ? NIL : def); value2 = NIL; mv_count=2; # NIL als 2. Wert
  994.         skipSTACK(2);
  995.       }
  996.   }}
  997.  
  998. # (SYSTEM::PUTHASH key hashtable value) =
  999. # (SETF (GETHASH key hashtable) value), CLTL S. 284
  1000. LISPFUNN(puthash,3)
  1001.   { var reg1 object ht = STACK_1; # hashtable-Argument
  1002.     if (!hash_table_p(ht)) { fehler_hashtable(ht); } # ⁿberprⁿfen
  1003.    {var object* KVptr;
  1004.     var object* Nptr;
  1005.     var object* Iptr;
  1006.     # Key STACK_2 in der Hash-Tabelle suchen:
  1007.     if (hash_lookup(ht,STACK_2,&KVptr,&Nptr,&Iptr))
  1008.       # gefunden -> Value ersetzen:
  1009.       { value1 = KVptr[1] = popSTACK(); mv_count=1; skipSTACK(2); }
  1010.       else
  1011.       # nicht gefunden -> neuen Eintrag basteln:
  1012.       { var reg2 object freelist;
  1013.         hash_prepare_store(STACK_2);
  1014.         hash_store(STACK_2,STACK_0); # Eintrag basteln
  1015.         value1 = popSTACK(); mv_count=1; # value als Wert
  1016.         skipSTACK(2);
  1017.       }
  1018.   }}
  1019.  
  1020. # UP: Sucht ein Key in einer Hash-Tabelle und liefert den vorigen Wert.
  1021. # shifthash(ht,obj,value) == (SHIFTF (GETHASH obj ht) value)
  1022. # > ht: Hash-Tabelle
  1023. # > obj: Objekt
  1024. # > value: neuer Wert
  1025. # < ergebnis: alter Wert
  1026. # kann GC ausl÷sen
  1027.   global object shifthash (object ht, object obj, object value);
  1028.   global object shifthash(ht,obj,value)
  1029.     var reg1 object ht;
  1030.     var reg3 object obj;
  1031.     var reg4 object value;
  1032.     { var object* KVptr;
  1033.       var object* Nptr;
  1034.       var object* Iptr;
  1035.       # Key obj in der Hash-Tabelle suchen:
  1036.       if (hash_lookup(ht,obj,&KVptr,&Nptr,&Iptr))
  1037.         # gefunden -> Value ersetzen:
  1038.         { var reg2 object oldvalue = KVptr[1];
  1039.           KVptr[1] = value;
  1040.           return oldvalue;
  1041.         }
  1042.         else
  1043.         # nicht gefunden -> neuen Eintrag basteln:
  1044.         { pushSTACK(obj); pushSTACK(value); # Key und Value retten
  1045.          {var reg2 object freelist;
  1046.           hash_prepare_store(STACK_1);
  1047.           hash_store(STACK_1,STACK_0); # Eintrag basteln
  1048.           skipSTACK(2);
  1049.           return NIL; # Default fⁿr den alten Wert ist NIL
  1050.         }}
  1051.     }
  1052.  
  1053. # (REMHASH key hashtable), CLTL S. 284
  1054. LISPFUNN(remhash,2)
  1055.   { var reg1 object ht = popSTACK(); # hashtable-Argument
  1056.     if (!hash_table_p(ht)) { fehler_hashtable(ht); } # ⁿberprⁿfen
  1057.    {var reg2 object key = popSTACK(); # key-Argument
  1058.     var object* KVptr;
  1059.     var object* Nptr;
  1060.     var object* Iptr;
  1061.     # Key in der Hash-Tabelle suchen:
  1062.     if (hash_lookup(ht,key,&KVptr,&Nptr,&Iptr))
  1063.       # gefunden -> aus der Hashtabelle streichen:
  1064.       { var reg3 object index = *Iptr; # Index im Next-Vektor
  1065.         # mit Nptr = &TheSvector(TheHashtable(ht)->ht_ntable)->data[index]
  1066.         # und KVptr = &TheSvector(TheHashtable(ht)->ht_kvtable)->data[2*index]
  1067.         set_break_sem_2(); # Vor Unterbrechungen schⁿtzen
  1068.         *Iptr = *Nptr; # "Liste" verkⁿrzen
  1069.         *KVptr++ = leer; *KVptr = leer; # Key und Value leeren
  1070.         # Freiliste verlΣngern:
  1071.         *Nptr = TheHashtable(ht)->ht_freelist;
  1072.         TheHashtable(ht)->ht_freelist = index;
  1073.         # COUNT decrementieren:
  1074.         TheHashtable(ht)->ht_count = fixnum_inc(TheHashtable(ht)->ht_count,-1);
  1075.         clr_break_sem_2(); # Unterbrechungen wieder zulassen
  1076.         # Bei COUNT < MINCOUNT die Hash-Tabelle verkleinern:
  1077.         if (posfixnum_to_L(TheHashtable(ht)->ht_count) < posfixnum_to_L(TheHashtable(ht)->ht_mincount))
  1078.           # Hash-Tabelle verkleinern:
  1079.           { # maxcount := (max (floor (/ maxcount rehash-size)) 1)
  1080.             pushSTACK(ht); # Hashtable retten
  1081.             pushSTACK(TheHashtable(ht)->ht_maxcount);
  1082.             pushSTACK(TheHashtable(ht)->ht_rehash_size); # REHASH-SIZE (>1)
  1083.             funcall(L(durch),2); # (/ maxcount rehash-size), ist < maxcount
  1084.             pushSTACK(value1);
  1085.             funcall(L(floor),1); # (floor ...), ein Integer >=0, < maxcount
  1086.            {var reg4 object maxcount = value1;
  1087.             if (eq(maxcount,Fixnum_0)) { maxcount = Fixnum_1; } # aus 0 mache 1
  1088.             resize(popSTACK(),maxcount); # Tabelle verkleinern
  1089.           }}
  1090.         value1 = T; mv_count=1; # T als Wert
  1091.       }
  1092.       else
  1093.       # nicht gefunden
  1094.       { value1 = NIL; mv_count=1; } # NIL als Wert
  1095.   }}
  1096.  
  1097. # (MAPHASH function hashtable), CLTL S. 285
  1098. LISPFUNN(maphash,2)
  1099.   { var reg3 object ht = STACK_0; # hashtable-Argument
  1100.     if (!hash_table_p(ht)) { fehler_hashtable(ht); } # ⁿberprⁿfen
  1101.     # Durch den Key-Value-Vektor von hinten durchlaufen und
  1102.     # fⁿr alle Key-Value-Paare mit Key /= "leer" die Funktion aufrufen:
  1103.    {var reg2 uintL index = 2*posfixnum_to_L(TheHashtable(ht)->ht_maxcount);
  1104.     STACK_0 = TheHashtable(ht)->ht_kvtable; # Key-Value-Vektor
  1105.     # Stackaufbau: function, Key-Value-Vektor.
  1106.     loop
  1107.       { if (index==0) break;
  1108.         index -= 2;
  1109.        {var reg1 object* KVptr = &TheSvector(STACK_0)->data[index];
  1110.         if (!eq(KVptr[0],leer)) # Key /= "leer" ?
  1111.           { pushSTACK(KVptr[0]); # Key als 1. Argument
  1112.             pushSTACK(KVptr[1]); # Value als 2. Argument
  1113.             funcall(STACK_(1+2),2); # (FUNCALL function Key Value)
  1114.       }}  }
  1115.     skipSTACK(2);
  1116.     value1 = NIL; mv_count=1; # NIL als Wert
  1117.   }}
  1118.  
  1119. # (CLRHASH hashtable), CLTL S. 285
  1120. LISPFUNN(clrhash,1)
  1121.   { var reg1 object ht = popSTACK(); # hashtable-Argument
  1122.     if (!hash_table_p(ht)) { fehler_hashtable(ht); } # ⁿberprⁿfen
  1123.     clrhash(ht); # Tabelle leeren
  1124.     # Bei MINCOUNT > 0 die Hash-Tabelle verkleinern:
  1125.     if (!eq(TheHashtable(ht)->ht_mincount,Fixnum_0))
  1126.       { ht = resize(ht,Fixnum_1); } # auf MAXCOUNT:=1 verkleinern, so da▀ MINCOUNT:=0
  1127.     value1 = ht; mv_count=1; # Hash-Tabelle als Wert
  1128.   }
  1129.  
  1130. # (HASH-TABLE-COUNT hashtable), CLTL S. 285
  1131. LISPFUNN(hash_table_count,1)
  1132.   { var reg1 object ht = popSTACK(); # hashtable-Argument
  1133.     if (!hash_table_p(ht)) { fehler_hashtable(ht); } # ⁿberprⁿfen
  1134.     value1 = TheHashtable(ht)->ht_count; mv_count=1; # Fixnum COUNT als Wert
  1135.   }
  1136.  
  1137. # Hilfsfunktionen fⁿr WITH-HASH-TABLE-ITERATOR, CLTL2 S. 439:
  1138. # (SYSTEM::HASH-TABLE-ITERATOR hashtable) liefert einen internen Zustand
  1139. # fⁿr das Iterieren durch eine Hash-Tabelle.
  1140. # (SYSTEM::HASH-TABLE-ITERATE internal-state) iteriert durch eine Hash-Tabelle
  1141. # um eins weiter, verΣndert dabei internal-state und liefert: 3 Werte
  1142. # T, key, value des nΣchsten Hash-Tabellen-Eintrags bzw. 1 Wert NIL am Schlu▀.
  1143.  
  1144. LISPFUNN(hash_table_iterator,1)
  1145.   { var reg1 object ht = STACK_0; # hashtable-Argument
  1146.     if (!hash_table_p(ht)) { fehler_hashtable(ht); } # ⁿberprⁿfen
  1147.     # Ein interner Zustand besteht aus dem Key-Value-Vektor und einem Index.
  1148.     STACK_0 = TheHashtable(ht)->ht_kvtable; # Key-Value-Vektor
  1149.    {var reg3 object maxcount = TheHashtable(ht)->ht_maxcount; # maxcount
  1150.     var reg2 object state = allocate_cons();
  1151.     Car(state) = popSTACK(); # Key-Value-Vektor als Car
  1152.     Cdr(state) = maxcount; # maxcount als Cdr
  1153.     value1 = state; mv_count=1; # state als Wert
  1154.   }}
  1155.  
  1156. LISPFUNN(hash_table_iterate,1)
  1157.   { var reg1 object state = popSTACK(); # interner Zustand
  1158.     if (consp(state)) # hoffentlich ein Cons
  1159.       { var reg4 object table = Car(state); # Key-Value-Vektor
  1160.         loop
  1161.           { var reg3 uintL index = posfixnum_to_L(Cdr(state));
  1162.             if (index==0) break; # index=0 -> keine Elemente mehr
  1163.             Cdr(state) = fixnum_inc(Cdr(state),-1); # Index decrementieren
  1164.            {var reg2 object* KVptr = &TheSvector(table)->data[2*index-2];
  1165.             if (!eq(KVptr[0],leer)) # Key /= "leer" ?
  1166.               { value2 = KVptr[0]; # Key als 2. Wert
  1167.                 value3 = KVptr[1]; # Value als 3. Wert
  1168.                 value1 = T; mv_count=3; return;
  1169.       }   }}  }
  1170.     value1 = NIL; mv_count=1; return; # 1 Wert NIL
  1171.   }
  1172.  
  1173. # (CLOS::CLASS-GETHASH ht object) ist wie (GETHASH (CLASS-OF object) ht).
  1174. LISPFUNN(class_gethash,2)
  1175.   { var reg1 object ht = STACK_1; # hashtable-Argument
  1176.     if (!hash_table_p(ht)) { fehler_hashtable(ht); } # ⁿberprⁿfen
  1177.     C_class_of(); # value1 := (CLASS-OF object)
  1178.    {var object* KVptr;
  1179.     var object* Nptr;
  1180.     var object* Iptr;
  1181.     # Key value1 in der Hash-Tabelle suchen:
  1182.     if (hash_lookup(ht,value1,&KVptr,&Nptr,&Iptr))
  1183.       # gefunden -> Value als Wert:
  1184.       { value1 = KVptr[1]; value2 = T; mv_count=2; } # und T als 2. Wert
  1185.       else
  1186.       # nicht gefunden -> NIL als Wert
  1187.       { value1 = NIL; value2 = NIL; mv_count=2; } # NIL als 2. Wert
  1188.     skipSTACK(1);
  1189.   }}
  1190.  
  1191. # (CLOS::CLASS-TUPLE-GETHASH ht object1 ... objectn)
  1192. # ist wie (GETHASH (funcall (hash-tuple-function n) class1 ... classn) ht)
  1193. # mit classi = (CLASS-OF objecti).
  1194. # Dabei sei n>0, ht eine EQUAL-Hashtabelle und (hash-tuple-function n) wie in
  1195. # clos.lsp definiert.
  1196. # Diese Funktion ist der Kern des Dispatch fⁿr generische Funktionen. Sie soll
  1197. # darum schnell sein und nicht consen.
  1198.   # Fⁿr 1 < n <= 16 ist
  1199.   #   (hash-tuple-function n ...) =
  1200.   #   (cons (hash-tuple-function n1 ...) (hash-tuple-function n2 ...))
  1201.     local uintC tuple_half_1 [17] = {0,0,1,1,2,2,2,3,4,4,4,4,4,5,6,7,8};
  1202.     local uintC tuple_half_2 [17] = {0,0,1,2,2,3,4,4,4,5,6,7,8,8,8,8,8};
  1203.   # Hilfsfunktion: Hashcode einer Reihe von Atomen berechnen, so als wΣren
  1204.   # sie per (hash-tuple-function n) zusammengeconst:
  1205.     local uint32 hashcode_tuple (uintC n, object* args_pointer, uintC depth);
  1206.     local uint32 hashcode_tuple(n,args_pointer,depth)
  1207.       var reg2 uintC n; # n > 0
  1208.       var reg1 object* args_pointer;
  1209.       var reg4 uintC depth;
  1210.       { if (n==1)
  1211.           { return hashcode1(Next(args_pointer)); } # hashcode_atom fⁿr Klassen
  1212.         elif (n<=16)
  1213.           { var reg6 uintC n1 = tuple_half_1[n];
  1214.             var reg7 uintC n2 = tuple_half_2[n]; # n1 + n2 = n
  1215.             var reg3 uint32 code1 = hashcode_tuple(n1,args_pointer,depth+1);
  1216.             var reg5 uint32 code2 = hashcode_tuple(n2,args_pointer STACKop -(uintP)n1,depth+1);
  1217.             switch (depth)
  1218.               { case 0: code1 = rotate_left(16,code1); break;
  1219.                 case 1: code1 = rotate_left(7,code1); break; # vgl. hashcode_cons3
  1220.                 case 2: code1 = rotate_left(5,code1); break; # vgl. hashcode_cons2
  1221.                 case 3: code1 = rotate_left(3,code1); break; # vgl. hashcode_cons1
  1222.                 default: NOTREACHED
  1223.               }
  1224.             return code1 ^ code2;
  1225.           }
  1226.         else # n>16, depth=0
  1227.           { var reg8 uint32 code1 = hashcode_tuple(8,args_pointer,1);
  1228.             var reg7 uint32 code2 = hashcode_tuple(4,args_pointer STACKop -8,2);
  1229.             var reg6 uint32 code3 = hashcode_tuple(2,args_pointer STACKop -12,3);
  1230.             var reg5 uint32 code4 = hashcode_tuple(1,args_pointer STACKop -14,4);
  1231.             var reg4 uint32 code = 1; # vgl. hashcode_cons0
  1232.             code = rotate_left(3,code4) ^ code; # vgl. hashcode_cons1
  1233.             code = rotate_left(5,code3) ^ code; # vgl. hashcode_cons2
  1234.             code = rotate_left(7,code2) ^ code; # vgl. hashcode_cons3
  1235.             code = rotate_left(16,code1) ^ code;
  1236.             return code;
  1237.       }   }
  1238.   # Hilfsfunktion: Vergleich eines Objekts mit einer Reihe von Atomen, so als
  1239.   # wΣren sie per (hash-tuple-function n) zusammengeconst:
  1240.     local boolean equal_tuple (object obj, uintC n, object* args_pointer);
  1241.     local boolean equal_tuple(obj,n,args_pointer)
  1242.       var reg1 object obj;
  1243.       var reg2 uintC n; # n > 0
  1244.       var reg3 object* args_pointer;
  1245.       { if (n==1)
  1246.           { if (eq(obj,Next(args_pointer)))
  1247.               { return TRUE; }
  1248.               else
  1249.               { return FALSE; }
  1250.           }
  1251.         elif (n<=16)
  1252.           { if (consp(obj))
  1253.               { var reg4 uintC n1 = tuple_half_1[n];
  1254.                 var reg5 uintC n2 = tuple_half_2[n]; # n1 + n2 = n
  1255.                 if (equal_tuple(Car(obj),n1,args_pointer)
  1256.                     && equal_tuple(Cdr(obj),n2,args_pointer STACKop -(uintP)n1)
  1257.                    )
  1258.                   return TRUE;
  1259.               }
  1260.             return FALSE;
  1261.           }
  1262.         else # n>16
  1263.           { if (consp(obj) && equal_tuple(Car(obj),8,args_pointer))
  1264.               { obj = Cdr(obj);
  1265.                 if (consp(obj) && equal_tuple(Car(obj),4,args_pointer STACKop -8))
  1266.                   { obj = Cdr(obj);
  1267.                     if (consp(obj) && equal_tuple(Car(obj),2,args_pointer STACKop -12))
  1268.                       { obj = Cdr(obj);
  1269.                         n-=14; args_pointer skipSTACKop -14;
  1270.                         # obj mit einer Liste der weiteren Atome vergleichen:
  1271.                         dotimespC(n,n,
  1272.                           { if (!(consp(obj) && eq(Car(obj),Next(args_pointer))))
  1273.                               return FALSE;
  1274.                             obj = Cdr(obj); args_pointer skipSTACKop -1;
  1275.                           });
  1276.                         if (nullp(obj))
  1277.                           # Vergleich erfⁿllt
  1278.                           { return TRUE; }
  1279.               }   }   }
  1280.             return FALSE;
  1281.       }   }
  1282.  
  1283. LISPFUN(class_tuple_gethash,2,0,rest,nokey,0,NIL)
  1284. { argcount++; rest_args_pointer skipSTACKop 1; # Argumente: ht {object}+
  1285.   # Zuerst CLASS-OF auf die einzelnen Argumente anwenden:
  1286.   { var reg1 object* arg_pointer = rest_args_pointer;
  1287.     var reg2 uintC count;
  1288.     dotimespC(count,argcount,
  1289.       { pushSTACK(Next(arg_pointer)); C_class_of(); # (CLASS-OF arg)
  1290.         NEXT(arg_pointer) = value1; # =: arg
  1291.       });
  1292.   }
  1293.  {var reg1 object ht = Before(rest_args_pointer); # hashtable-Argument
  1294.   if (!hash_table_p(ht)) { fehler_hashtable(ht); } # ⁿberprⁿfen
  1295.   if (!ht_validp(TheHashtable(ht)))
  1296.     # Hash-Tabelle mu▀ erst noch reorganisiert werden
  1297.     { rehash(ht); }
  1298.   { var reg7 uint32 code = # Hashcode des Cons-Baumes berechnen
  1299.       hashcode_tuple(argcount,rest_args_pointer,0);
  1300.     var reg6 uintL hashindex;
  1301.     divu_3232_3232(code,posfixnum_to_L(TheHashtable(ht)->ht_size),,hashindex = );
  1302.    {var reg2 object* Nptr = # Pointer auf den aktuellen Eintrag
  1303.       &TheSvector(TheHashtable(ht)->ht_itable)->data[hashindex];
  1304.     loop
  1305.       { # "Liste" weiterverfolgen:
  1306.         if (eq(*Nptr,nix)) break; # "Liste" zu Ende -> nicht gefunden
  1307.         { var reg3 uintL index = posfixnum_to_L(*Nptr); # nΣchster Index
  1308.           Nptr = # Pointer auf Eintrag im Next-Vektor
  1309.             &TheSvector(TheHashtable(ht)->ht_ntable)->data[index];
  1310.          {var reg4 object* KVptr = # Pointer auf EintrΣge im Key-Value-Vektor
  1311.             &TheSvector(TheHashtable(ht)->ht_kvtable)->data[2*index];
  1312.           if (equal_tuple(KVptr[0],argcount,rest_args_pointer)) # Key vergleichen
  1313.             # gefunden
  1314.             { value1 = KVptr[1]; goto fertig; } # Value als Wert
  1315.       } }}
  1316.   }}
  1317.   # nicht gefunden
  1318.   value1 = NIL;
  1319.   fertig:
  1320.   mv_count=1;
  1321.   set_args_end_pointer(rest_args_pointer STACKop 1); # STACK aufrΣumen
  1322. }}
  1323.  
  1324. # UP: Berechnet einen portablen EQUAL-Hashcode eines Objekts.
  1325. # sxhash(obj)
  1326. # Er ist nur bis zur nΣchsten Modifizierung des Objekts gⁿltig.
  1327. # Aus (equal X Y) folgt (= (sxhash X) (sxhash Y)).
  1328. # > obj: ein Objekt
  1329. # < ergebnis: Hashcode, eine 32-Bit-Zahl
  1330.   local uint32 sxhash (object obj);
  1331. # Hilfsfunktionen bei bekanntem Typ:
  1332.   # Atom -> Fallunterscheidung nach Typ
  1333.   local uint32 sxhash_atom (object obj);
  1334.   local uint32 sxhash_atom(obj)
  1335.     var reg1 object obj;
  1336.     { switch (typecode(obj)) # je nach Typ
  1337.         { case_symbol: # Symbol
  1338.             # Printname verwerten
  1339.             # (nicht auch die Home-Package, da sie sich bei UNINTERN verΣndert)
  1340.             return hashcode_string(Symbol_name(obj))+0x339B0E4CUL;
  1341.           case_machine: # Maschinenpointer
  1342.           default:
  1343.             # Adresse darf nicht verwendet werden, nur den Typ verwerten
  1344.             return highlow32(typecode(obj),0xDABE); # Typinfo*2^16+Kennung
  1345.           case_bvector: # bit-vector
  1346.             # Bit-Vektor-Inhalt
  1347.             return hashcode_bvector(obj);
  1348.           case_string: # String
  1349.             # String-Inhalt
  1350.             return hashcode_string(obj);
  1351.           case_svector: # Simple-Vector
  1352.             # nur die LΣnge verwerten
  1353.             return TheSvector(obj)->length + 0x4ECD0A9FUL;
  1354.           case_ovector: # (vector t)
  1355.           case_array1: # allgemeiner Array
  1356.             # mehrdimensionaler Array -> nur Rang verwerten
  1357.             return TheArray(obj)->rank + 0xAAFAFAAEUL;
  1358.           case_structure: # Structure
  1359.             # nur Structure-Typ (Liste (name_1 name_2 ... . name_n)) verwerten
  1360.             { check_SP();
  1361.               return sxhash(TheStructure(obj)->structure_types) + 0xAD2CD2AEUL;
  1362.             }
  1363.           case_stream: # Stream
  1364.             # nur Streamtyp verwerten
  1365.             return TheStream(obj)->strmtype + 0x3DAEAE55UL;
  1366.          {var reg3 uint32 bish_code;
  1367.           case_closure: # Closure
  1368.             # alle Elemente verwerten ??
  1369.             bish_code = 0xB0DD939EUL; goto record_all;
  1370.           case_orecord: # OtherRecord
  1371.             # Record-Typ verwerten, au▀erdem:
  1372.             # Package: Package-Name verwerten (nicht ganz OK, da eine
  1373.             #          Package mit RENAME-PACKAGE umbenannt werden kann!)
  1374.             # Pathname, Byte, LoadTimeEval: alle Komponenten verwerten
  1375.             # Hash-Table, Readtable, Random-State, Symbol-Macro: nichts weiter
  1376.             { var reg6 uintB rectype = TheRecord(obj)->rectype;
  1377.               #ifndef case_structure
  1378.               if (rectype == Rectype_Structure) goto case_structure;
  1379.               #endif
  1380.               #ifndef case_stream
  1381.               if (rectype == Rectype_Stream) goto case_stream;
  1382.               #endif
  1383.               bish_code = 0xB04D939EUL + rectype;
  1384.               if (rectype == Rectype_Package) # Package ?
  1385.                 # Package-Name verwerten
  1386.                 { var reg4 uint32 next_code = hashcode_string(ThePackage(obj)->pack_name);
  1387.                   return rotate_left(1,next_code) + bish_code;
  1388.                 }
  1389.               elif (rectype == Rectype_Fsubr) # Fsubr ?
  1390.                 # Namen verwerten
  1391.                 { check_SP(); return sxhash(TheFsubr(obj)->name) + 0xFF3319BAUL; }
  1392.               elif ((rectype == Rectype_Pathname) # Pathname ?
  1393.                     #ifdef LOGICAL_PATHNAMES
  1394.                     || (rectype == Rectype_Logpathname) # Pathname ?
  1395.                     #endif
  1396.                     || (rectype == Rectype_Byte) # Byte ?
  1397.                     || (rectype == Rectype_Loadtimeeval) # LoadTimeEval ?
  1398.                    )
  1399.                 goto record_all;
  1400.               else
  1401.                 { return bish_code; }
  1402.             }
  1403.           record_all:
  1404.             #  Record, in dem man alle Elemente verwerten kann
  1405.             check_SP();
  1406.             { var reg2 object* ptr = &TheRecord(obj)->recdata[0];
  1407.               var reg5 uintC count = TheRecord(obj)->reclength;
  1408.               dotimespC(count,count,
  1409.                 # Hashcode der nΣchsten Komponente dazunehmen:
  1410.                 { var reg4 uint32 next_code = sxhash(*ptr++);
  1411.                   bish_code = misch(bish_code,next_code);
  1412.                 });
  1413.               return bish_code;
  1414.             }
  1415.          }
  1416.           case_instance: # Instanz
  1417.             # nur Klasse verwerten
  1418.             return sxhash(TheInstance(obj)->class) + 0x61EFA249;
  1419.           case_char: # Character
  1420.             # EQ-Hashcode nehmen (bei Characters ist ja EQUAL == EQL == EQ)
  1421.             return hashcode1(obj);
  1422.           case_subr: # SUBR
  1423.             # Namen verwerten
  1424.             check_SP(); return sxhash(TheSubr(obj)->name) + 0xFF3319BAUL;
  1425.           case_system: # Frame-Pointer, Read-Label, System
  1426.             # Adresse verwenden
  1427.             return hashcode1(obj);
  1428.           # Zahlen: nach Inhalt, wie bei EQL
  1429.           case_fixnum: # Fixnum
  1430.             return hashcode_fixnum(obj);
  1431.           case_bignum: # Bignum
  1432.             return hashcode_bignum(obj);
  1433.           case_sfloat: # Short-Float
  1434.             return hashcode_sfloat(obj);
  1435.           case_ffloat: # Single-Float
  1436.             return hashcode_ffloat(obj);
  1437.           case_dfloat: # Double-Float
  1438.             return hashcode_dfloat(obj);
  1439.           case_lfloat: # Long-Float
  1440.             return hashcode_lfloat(obj);
  1441.           case_ratio: # Ratio
  1442.             # beide Komponenten hashen, mischen
  1443.             { var reg2 uint32 code1 = sxhash(TheRatio(obj)->rt_num);
  1444.               var reg3 uint32 code2 = sxhash(TheRatio(obj)->rt_den);
  1445.               return misch(code1,code2);
  1446.             }
  1447.           case_complex: # Complex
  1448.             # beide Komponenten hashen, mischen
  1449.             { var reg2 uint32 code1 = sxhash(TheComplex(obj)->c_real);
  1450.               var reg3 uint32 code2 = sxhash(TheComplex(obj)->c_imag);
  1451.               return misch(code1,code2);
  1452.             }
  1453.     }   }
  1454. # Cons -> Inhalt bis zur Tiefe 4 ansehen:
  1455. # Jeweils Hashcode des CAR und Hashcode des CDR bestimmen
  1456. # und geshiftet kombinieren. Als Shifts passen z.B. 16,7,5,3,
  1457. # da {0,16} + {0,7} + {0,5} + {0,3} = {0,3,5,7,8,10,12,15,16,19,21,23,24,26,28,31}
  1458. # aus 16 verschiedenen Elementen von {0,...,31} besteht.
  1459.   # Objekt, bei Cons nur bis Tiefe 0
  1460.   local uint32 sxhash_cons0 (object obj);
  1461.   local uint32 sxhash_cons0(obj)
  1462.     var reg1 object obj;
  1463.     { if (atomp(obj))
  1464.         { return sxhash_atom(obj); }
  1465.         else
  1466.         # Cons -> Hashcode := 1
  1467.         { return 1; }
  1468.     }
  1469.   # Objekt, bei Cons nur bis Tiefe 1
  1470.   local uint32 sxhash_cons1 (object obj);
  1471.   local uint32 sxhash_cons1(obj)
  1472.     var reg1 object obj;
  1473.     { if (atomp(obj))
  1474.         { return sxhash_atom(obj); }
  1475.         else
  1476.         # Cons -> Hashcode des CAR und des CDR bestimmen und mischen:
  1477.         { var reg2 uint32 code1 = sxhash_cons0(Car(obj));
  1478.           var reg3 uint32 code2 = sxhash_cons0(Cdr(obj));
  1479.           return rotate_left(3,code1) ^ code2;
  1480.     }   }
  1481.   # Objekt, bei Cons nur bis Tiefe 2
  1482.   local uint32 sxhash_cons2 (object obj);
  1483.   local uint32 sxhash_cons2(obj)
  1484.     var reg1 object obj;
  1485.     { if (atomp(obj))
  1486.         { return sxhash_atom(obj); }
  1487.         else
  1488.         # Cons -> Hashcode des CAR und des CDR bestimmen und mischen:
  1489.         { var reg2 uint32 code1 = sxhash_cons1(Car(obj));
  1490.           var reg3 uint32 code2 = sxhash_cons1(Cdr(obj));
  1491.           return rotate_left(5,code1) ^ code2;
  1492.     }   }
  1493.   # Objekt, bei Cons nur bis Tiefe 3
  1494.   local uint32 sxhash_cons3 (object obj);
  1495.   local uint32 sxhash_cons3(obj)
  1496.     var reg1 object obj;
  1497.     { if (atomp(obj))
  1498.         { return sxhash_atom(obj); }
  1499.         else
  1500.         # Cons -> Hashcode des CAR und des CDR bestimmen und mischen:
  1501.         { var reg2 uint32 code1 = sxhash_cons2(Car(obj));
  1502.           var reg3 uint32 code2 = sxhash_cons2(Cdr(obj));
  1503.           return rotate_left(7,code1) ^ code2;
  1504.     }   }
  1505.   # Objekt, bei Cons nur bis Tiefe 4
  1506.   local uint32 sxhash(obj)
  1507.     var reg1 object obj;
  1508.     { if (atomp(obj))
  1509.         { return sxhash_atom(obj); }
  1510.         else
  1511.         # Cons -> Hashcode des CAR und des CDR bestimmen und mischen:
  1512.         { var reg2 uint32 code1 = sxhash_cons3(Car(obj));
  1513.           var reg3 uint32 code2 = sxhash_cons3(Cdr(obj));
  1514.           return rotate_left(16,code1) ^ code2;
  1515.     }   }
  1516.  
  1517. # (SXHASH object), CLTL S. 285
  1518. LISPFUNN(sxhash,1)
  1519.   { value1 = UL_to_I(sxhash(popSTACK())); mv_count=1; } # Hashcode als Integer
  1520.  
  1521.