home *** CD-ROM | disk | FTP | other *** search
/ Amiga ISO Collection / AmigaUtilCD2.iso / Programming / Misc / CLISP-1.LHA / CLISP960530-sr.lha / src / hashtabl.d < prev    next >
Encoding:
Text File  |  1996-04-15  |  69.2 KB  |  1,547 lines
  1. # Hash-Tabellen in CLISP
  2. # Bruno Haible 14.6.1995
  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)as_oint(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),_EMA_,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.         //: DEUTSCH "Zu große Hashtabellengröße ~"
  611.         //: ENGLISH "Hash table size ~ too large"
  612.         //: FRANCAIS "La taille ~ est trop grande pour une table de hachage."
  613.         fehler(type_error, GETTEXT("Hash table size ~ too large"));
  614.     }
  615.  
  616.   local void fehler_resizing_hash_table (object ht);
  617.   local void fehler_resizing_hash_table(ht)
  618.     var object ht;
  619.     {
  620.       pushSTACK(ht); # Hash-Table
  621.       //: DEUTSCH "Interner Fehler beim Reorganisieren von ~."
  622.       //: ENGLISH "internal error occured while resizing ~"
  623.       //: FRANCAIS "Une erreur interne s'est produite au moment de la réorganisation de ~."
  624.       fehler(serious_condition, GETTEXT("internal error occured while resizing ~"));
  625.     }
  626.  
  627. # UP: Vergrößert oder verkleinert eine Hash-Tabelle
  628. # resize(ht,maxcount)
  629. # > ht: Hash-Table
  630. # > maxcount: gewünschte neue Größe MAXCOUNT
  631. # < ergebnis: Hash-Table, EQ zur alten
  632. # kann GC auslösen
  633.   local object resize (object ht, object maxcount);
  634.   local object resize(ht,maxcount)
  635.     var reg8 object ht;
  636.     var reg9 object maxcount;
  637.     { pushSTACK(ht);
  638.      {var reg9 uintL maxcountL =
  639.         prepare_resize(maxcount,TheHashtable(ht)->ht_mincount_threshold);
  640.       # Ab jetzt keine GC mehr!
  641.       var reg9 object KVvektor = popSTACK(); # neuer Key-Value-Vektor
  642.       var reg10 object Nvektor = popSTACK(); # Next-Vektor
  643.       var reg10 object Ivektor = popSTACK(); # Index-Vektor
  644.       var reg10 object mincount = popSTACK(); # MINCOUNT
  645.       var reg10 object size = popSTACK(); # SIZE
  646.       maxcount = popSTACK();
  647.       ht = popSTACK();
  648.       # Neuen Key-Value-Vektor füllen:
  649.       # Durch den alten Key-Value-Vektor durchlaufen und
  650.       # alle Key-Value-Paare mit Key /= "leer" kopieren:
  651.       { # Zum Durchlaufen des alten Key-Value-Vektors:
  652.         var reg3 uintL oldcount = posfixnum_to_L(TheHashtable(ht)->ht_maxcount);
  653.         var reg1 object* oldKVptr = &TheSvector(TheHashtable(ht)->ht_kvtable)->data[0];
  654.         # Zum Durchlaufen des neuen Key-Value-Vektors:
  655.         var reg4 uintL count = maxcountL;
  656.         var reg2 object* KVptr = &TheSvector(KVvektor)->data[0];
  657.         # Zum Mitzählen:
  658.         var reg7 object counter = Fixnum_0;
  659.         dotimesL(oldcount,oldcount,
  660.           { var reg5 object nextkey = *oldKVptr++; # nächster Key
  661.             var reg6 object nextvalue = *oldKVptr++; # und Value
  662.             if (!eq(nextkey,leer))
  663.               # Eintrag in den neuen Key-Value-Vektor übernehmen:
  664.               { if (count==0) # Ist der neue Vektor schon voll?
  665.                   # Der Platz reicht nicht!!
  666.                   fehler_resizing_hash_table(ht);
  667.                 count--;
  668.                 *KVptr++ = nextkey; *KVptr++ = nextvalue; # im neuen Vektor ablegen
  669.                 counter = fixnum_inc(counter,1); # und mitzählen
  670.               }
  671.           });
  672.         # Noch count Paare des neuen Key-Value-Vektors als "leer" markieren:
  673.         dotimesL(count,count, { *KVptr++ = leer; *KVptr++ = leer; } );
  674.         # Hash-Tabelle modifizieren:
  675.         set_break_sem_2(); # Vor Unterbrechungen schützen
  676.         mark_ht_invalid(TheHashtable(ht)); # Tabelle muß erst noch reorganisiert werden
  677.         TheHashtable(ht)->ht_size = size; # neues SIZE eintragen
  678.         TheHashtable(ht)->ht_itable = Ivektor; # neuen Index-Vektor eintragen
  679.         TheHashtable(ht)->ht_maxcount = maxcount; # neues MAXCOUNT eintragen
  680.         TheHashtable(ht)->ht_freelist = nix; # Dummy als Freiliste
  681.         TheHashtable(ht)->ht_ntable = Nvektor; # neuen Next-Vektor eintragen
  682.         TheHashtable(ht)->ht_kvtable = KVvektor; # neuen Key-Value-Vektor eintragen
  683.         TheHashtable(ht)->ht_count = counter; # COUNT eintragen (konsistenzhalber)
  684.         TheHashtable(ht)->ht_mincount = mincount; # neues MINCOUNT eintragen
  685.         clr_break_sem_2(); # Unterbrechungen wieder zulassen
  686.         return ht;
  687.     }}}
  688.  
  689. # Macro: Vergrößert eine Hash-Tabelle so lange, bis freelist /= nix
  690. # hash_prepare_store();
  691. # > object key: Key (im Stack)
  692. # > object ht: Hash-Tabelle
  693. # < object ht: Hash-Tabelle
  694. # < object freelist: Anfang der Freiliste im Next-Vektor, /= nix
  695. # < object* Iptr: beliebiges Element der "Liste", die zu Key gehört
  696. # kann GC auslösen
  697.   #define hash_prepare_store(key)  \
  698.     { retry:                                                                    \
  699.       freelist = TheHashtable(ht)->ht_freelist;                                 \
  700.       if (eq(freelist,nix)) # Freiliste = leere "Liste" ?                       \
  701.         # ja -> muß die Hash-Tabelle vergrößern:                                \
  702.         { pushSTACK(ht); # Hashtable retten                                     \
  703.           # neues maxcount ausrechnen:                                          \
  704.           pushSTACK(TheHashtable(ht)->ht_maxcount);                             \
  705.           pushSTACK(TheHashtable(ht)->ht_rehash_size); # REHASH-SIZE (>1)       \
  706.           funcall(L(mal),2); # (* maxcount rehash-size), ist > maxcount         \
  707.           pushSTACK(value1);                                                    \
  708.           funcall(L(ceiling),1); # (ceiling ...), Integer > maxcount            \
  709.           ht = resize(popSTACK(),value1); # Tabelle vergrößern                  \
  710.           rehash(ht); # und reorganisieren                                      \
  711.           # Adresse des Eintrags im Index-Vektor neu ausrechnen:                \
  712.          {var reg3 uintL hashindex = hashcode(ht,key); # Hashcode berechnen     \
  713.           Iptr = &TheSvector(TheHashtable(ht)->ht_itable)->data[hashindex];     \
  714.           goto retry;                                                           \
  715.         }}                                                                      \
  716.     }
  717.  
  718. # UP: Löscht den Inhalt einer Hash-Tabelle.
  719. # clrhash(ht);
  720. # > ht: Hash-Tabelle
  721.   local void clrhash (object ht);
  722.   local void clrhash(ht)
  723.     var reg3 object ht;
  724.     { set_break_sem_2(); # Vor Unterbrechungen schützen
  725.       {var reg1 object* KVptr = &TheSvector(TheHashtable(ht)->ht_kvtable)->data[0];
  726.        var reg2 uintL count = posfixnum_to_L(TheHashtable(ht)->ht_maxcount);
  727.        dotimesL(count,count, # in jedem Eintrag
  728.          { *KVptr++ = leer; *KVptr++ = leer; # Key und Value leeren
  729.          });
  730.       }
  731.       TheHashtable(ht)->ht_count = Fixnum_0; # COUNT := 0
  732.       mark_ht_invalid(TheHashtable(ht)); # Hashtabelle später noch reorganisieren
  733.       clr_break_sem_2(); # Unterbrechungen wieder zulassen
  734.     }
  735.  
  736. # (MAKE-HASH-TABLE [:test] [:size] [:rehash-size] [:rehash-threshold]
  737. #                  [:initial-contents]), CLTL S. 283
  738. LISPFUN(make_hash_table,0,0,norest,key,5,\
  739.         (kw(initial_contents),\
  740.          kw(test),kw(size),kw(rehash_size),kw(rehash_threshold)) )
  741.   { # Dem Rehash-Threshold entspricht in unserer Implementation das
  742.     # Verhältnis MAXCOUNT : SIZE = ca. 1 : 2.
  743.     # Wir ignorieren das rehash-threshold-Argument, da sowohl zu große als
  744.     # auch zu kleine Werte davon schädlich wären: 0.99 bewirkt im Durchschnitt
  745.     # zu lange Zugriffszeiten; 0.00001 bewirkt, daß SIZE = MAXCOUNT/threshold
  746.     # zu schnell ein Bignum werden könnte.
  747.     # Das zusätzliche initial-contents-Argument ist eine Aliste = Liste von
  748.     # (Key . Value) - Paaren, mit denen die Tabelle initialisiert wird.
  749.     # Stackaufbau: initial-contents, test, size, rehash-size, rehash-threshold.
  750.     var reg3 uintB flags;
  751.     # test-Argument überprüfen:
  752.     { var reg1 object test = STACK_3;
  753.       if (eq(test,unbound))
  754.         { flags = bit(1); } # EQL als Default
  755.       elif (eq(test,S(eq)) || eq(test,L(eq)))
  756.         { flags = bit(0); } # EQ
  757.       elif (eq(test,S(eql)) || eq(test,L(eql)))
  758.         { flags = bit(1); } # EQL
  759.       elif (eq(test,S(equal)) || eq(test,L(equal)))
  760.         { flags = bit(2); } # EQUAL
  761.       else
  762.         { pushSTACK(test); # Wert für Slot DATUM von TYPE-ERROR
  763.           pushSTACK(O(type_hashtable_test)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  764.           pushSTACK(test);
  765.           pushSTACK(S(make_hash_table));
  766.           //: DEUTSCH "~: Unzulässiges :TEST-Argument ~"
  767.           //: ENGLISH "~: illegal :TEST argument ~"
  768.           //: FRANCAIS "~: Argument pour :TEST illicite : ~"
  769.           fehler(type_error, GETTEXT("~: illegal :TEST argument ~"));
  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.               //: DEUTSCH "~: :SIZE-Argument sollte ein Fixnum >=0 sein, nicht ~"
  783.               //: ENGLISH "~: :SIZE argument should be a fixnum >=0, not ~"
  784.               //: FRANCAIS "~: L'argument :SIZE doit être de type FIXNUM positif ou zéro et non ~."
  785.               fehler(type_error, GETTEXT("~: :SIZE argument should be a fixnum >=0, not ~"));
  786.             }
  787.           # size ist ein Fixnum >=0
  788.           if (eq(size,Fixnum_0)) { STACK_2 = Fixnum_1; } # aus 0 mache 1
  789.     }   }
  790.     # size ist jetzt ein Fixnum >0.
  791.     # rehash-size überprüfen:
  792.     { if (eq(STACK_1,unbound))
  793.         # Default-Rehash-Size = 1.5s0
  794.         { STACK_1 = make_SF(0,SF_exp_mid+1,(bit(SF_mant_len)*3)/2); }
  795.         else
  796.         { if (!mfloatp(STACK_1)) # Float ist OK
  797.             { if (!mposfixnump(STACK_1)) # sonst sollte es ein Fixnum >=0 sein
  798.                 { fehler_rehash_size:
  799.                   pushSTACK(STACK_1); # Wert für Slot DATUM von TYPE-ERROR
  800.                   pushSTACK(O(type_hashtable_rehash_size)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  801.                   pushSTACK(STACK_(1+2));
  802.                   pushSTACK(S(make_hash_table));
  803.                   //: DEUTSCH "~: :REHASH-SIZE-Argument sollte ein Float > 1 sein, nicht ~"
  804.                   //: ENGLISH "~: :REHASH-SIZE argument should be a float > 1, not ~"
  805.                   //: FRANCAIS "~: L'argument :REHASH-SIZE devrait être un nombre à virgule flottante supérieur à 1 et non ~."
  806.                   fehler(type_error, GETTEXT("~: :REHASH-SIZE argument should be a float > 1, not ~"));
  807.                 }
  808.               # Da es sinnlos ist, eine Tabelle immer nur um eine feste
  809.               # Anzahl von Elementen größer zu machen (führt zu katastrophaler
  810.               # Effizienz), wird rehash-size := min(1 + rehash-size/size , 2.0)
  811.               # gesetzt.
  812.               pushSTACK(STACK_1); # rehash-size
  813.               pushSTACK(STACK_(2+1)); # size
  814.               funcall(L(durch),2); # (/ rehash-size size)
  815.               pushSTACK(value1);
  816.               funcall(L(einsplus),1); # (1+ ...)
  817.               pushSTACK(value1);
  818.               pushSTACK(make_SF(0,SF_exp_mid+2,bit(SF_mant_len))); # 2.0s0
  819.               funcall(L(min),2); # (MIN ... 2.0s0)
  820.               STACK_1 = value1; # =: rehash-size
  821.             }
  822.           # (> rehash-size 1) überprüfen:
  823.           pushSTACK(STACK_1); # rehash-size
  824.           pushSTACK(Fixnum_1); # 1
  825.           funcall(L(groesser),2); # (> rehash-size 1)
  826.           if (nullp(value1)) goto fehler_rehash_size;
  827.           # rehash-size in ein Short-Float umwandeln:
  828.           pushSTACK(STACK_1); # rehash-size
  829.           pushSTACK(SF_0); # 0.0s0
  830.           funcall(L(float),2); # (FLOAT rehash-size 0.0s0) = (COERCE rehash-size 'SHORT-FLOAT)
  831.           # (>= rehash-size 1.125s0) erzwingen:
  832.           pushSTACK(value1);
  833.           pushSTACK(make_SF(0,SF_exp_mid+1,(bit(SF_mant_len)/8)*9)); # 1.125s0
  834.           funcall(L(max),2); # (max rehash-size 1.125s0)
  835.           STACK_1 = value1; # =: rehash-size
  836.     }   }
  837.     # rehash-size ist ein Short-Float >= 1.125 .
  838.     # rehash-threshold überprüfen: sollte ein Float >=0, <=1 sein
  839.     { var reg1 object rehash_threshold = STACK_0;
  840.       if (!eq(rehash_threshold,unbound)) # nicht angegeben -> OK
  841.         { if (!floatp(rehash_threshold))
  842.             { fehler_rehash_threshold:
  843.               # Argument bereits in STACK_0, Wert für Slot DATUM von TYPE-ERROR
  844.               pushSTACK(O(type_hashtable_rehash_threshold)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  845.               pushSTACK(STACK_1);
  846.               pushSTACK(S(make_hash_table));
  847.               //: DEUTSCH "~: :REHASH-THRESHOLD-Argument sollte ein Float zwischen 0 und 1 sein, nicht ~"
  848.               //: ENGLISH "~: :REHASH-THRESHOLD argument should be a float between 0 and 1, not ~"
  849.               //: FRANCAIS "~: L'argument :REHASH-THRESHOLD devrait être un nombre à virgule flottante compris entre 0 et 1 et non ~."
  850.               fehler(type_error, GETTEXT("~: :REHASH-THRESHOLD argument should be a float between 0 and 1, not ~"));
  851.             }
  852.           pushSTACK(Fixnum_1);
  853.           pushSTACK(rehash_threshold);
  854.           pushSTACK(Fixnum_0);
  855.           funcall(L(grgleich),3); # (>= 1 rehash-threshold 0)
  856.           if (nullp(value1)) goto fehler_rehash_threshold;
  857.     }   }
  858.     # Nun sind alle Argumente überprüft.
  859.     # Ist das initial-contents-Argument angegeben, so wird
  860.     # size := (max size (length initial-contents)) gesetzt, damit nachher beim
  861.     # Eintragen des initial-contents die Tabelle nicht vergrößert werden muß:
  862.     { var reg1 object initial_contents = STACK_4;
  863.       if (!eq(initial_contents,unbound)) # angegeben ?
  864.         { var reg1 uintL initial_length = llength(initial_contents); # Länge der Aliste
  865.           if (initial_length > posfixnum_to_L(STACK_2)) # > size ?
  866.             { STACK_2 = fixnum(initial_length); } # ja -> size vergrößern
  867.     }   }
  868.     # size ist ein Fixnum >0, >= (length initial-contents) .
  869.     # MINCOUNT-THRESHOLD = 1/rehash-size^2 errechnen:
  870.     { var reg1 object rehash_size = STACK_1;
  871.       pushSTACK(rehash_size);
  872.       pushSTACK(rehash_size);
  873.       funcall(L(mal),2); # (* rehash-size rehash-size)
  874.       pushSTACK(value1);
  875.       funcall(L(durch),1); # (/ ...)
  876.       STACK_0 = value1;
  877.     }
  878.     # Stackaufbau: initial-contents, test, size, rehash-size, mincount-threshold.
  879.     # Vektoren beschaffen usw., mit size als MAXCOUNT:
  880.     prepare_resize(STACK_2,STACK_0);
  881.     { var reg1 object ht = allocate_hash_table(); # neue Hash-Tabelle
  882.       # füllen:
  883.       TheHashtable(ht)->ht_kvtable = popSTACK(); # Key-Value-Vektor
  884.       TheHashtable(ht)->ht_ntable = popSTACK(); # Next-Vektor
  885.       TheHashtable(ht)->ht_itable = popSTACK(); # Index-Vektor
  886.       TheHashtable(ht)->ht_mincount = popSTACK(); # MINCOUNT
  887.       TheHashtable(ht)->ht_size = popSTACK(); # SIZE
  888.       TheHashtable(ht)->ht_maxcount = popSTACK(); # MAXCOUNT
  889.       # Stackaufbau: initial-contents, test, size, rehash-size, mincount-threshold.
  890.       TheHashtable(ht)->ht_mincount_threshold = popSTACK(); # MINCOUNT-THRESHOLD
  891.       TheHashtable(ht)->ht_rehash_size = popSTACK(); # REHASH-SIZE
  892.       TheHashtable(ht)->ht_freelist = nix; # Dummy als Freiliste
  893.       TheHashtable(ht)->recflags = flags;
  894.       clrhash(ht); # Tabelle leeren, COUNT := 0
  895.       skipSTACK(2);
  896.       # Stackaufbau: initial-contents.
  897.       { var reg2 object alist = popSTACK(); # initial-contents
  898.         while (consp(alist)) # Wenn es angegeben war, solange es ein Cons ist:
  899.           { var reg3 object next = Car(alist); # Alistenelement
  900.             if (consp(next)) # ein Cons (Key . Value) ?
  901.               # (SYSTEM::PUTHASH (car next) hashtable (cdr next)) ausführen,
  902.               # wobei die Tabelle nicht wachsen kann:
  903.               { var reg8 object key = Car(next);
  904.                 var object* KVptr;
  905.                 var object* Nptr;
  906.                 var object* Iptr;
  907.                 if (hash_lookup(ht,key,&KVptr,&Nptr,&Iptr)) # in der Hash-Tabelle suchen
  908.                   # schon gefunden -> war in der Aliste weiter links schon
  909.                   # enthalten, und in Alisten verdeckt die erste Assoziation
  910.                   # (links) alle anderen Assoziationen zum selben Key.
  911.                   {}
  912.                   else
  913.                   # nicht gefunden -> neuen Eintrag basteln:
  914.                   { var reg7 object freelist = # Anfang der Freiliste im Next-Vektor
  915.                       TheHashtable(ht)->ht_freelist;
  916.                     if (eq(freelist,nix)) # leere "Liste" ?
  917.                       { pushSTACK(ht); # Hash-Tabelle
  918.                         pushSTACK(S(make_hash_table));
  919.                         //: DEUTSCH "~: Interner Fehler beim Aufbauen von ~"
  920.                         //: ENGLISH "~: internal error while building ~"
  921.                         //: FRANCAIS "~: Une erreur interne s'est produite lors de la construction de ~."
  922.                         fehler(serious_condition, GETTEXT("~: internal error while building ~"));
  923.                       }
  924.                     hash_store(key,Cdr(next)); # Eintrag basteln
  925.               }   }
  926.             alist = Cdr(alist);
  927.           }
  928.       }
  929.       value1 = ht; mv_count=1; # Hash-Tabelle als Wert
  930.   } }
  931.  
  932. # UP: Sucht ein Objekt in einer Hash-Tabelle.
  933. # gethash(obj,ht)
  934. # > obj: Objekt, als Key
  935. # > ht: Hash-Tabelle
  936. # < ergebnis: zugehöriger Value, falls gefunden, nullobj sonst
  937.   global object gethash (object obj, object ht);
  938.   global object gethash(obj,ht)
  939.     var reg2 object obj;
  940.     var reg1 object ht;
  941.     { var object* KVptr;
  942.       var object* Nptr;
  943.       var object* Iptr;
  944.       if (hash_lookup(ht,obj,&KVptr,&Nptr,&Iptr))
  945.         { return KVptr[1]; } # gefunden -> Value
  946.         else
  947.         { return nullobj; }
  948.     }
  949.  
  950. # Fehler, wenn ein Argument keine Hash-Table ist
  951. # fehler_hashtable(obj);
  952. # > obj: Objekt
  953. # > subr_self: Aufrufer (ein SUBR)
  954.   nonreturning_function(local, fehler_hashtable, (object obj));
  955.   local void fehler_hashtable(obj)
  956.     var reg1 object obj;
  957.     { pushSTACK(obj); # Wert für Slot DATUM von TYPE-ERROR
  958.       pushSTACK(S(hash_table)); # Wert für Slot EXPECTED-TYPE von TYPE-ERROR
  959.       pushSTACK(obj);
  960.       pushSTACK(TheSubr(subr_self)->name);
  961.       //: DEUTSCH "~: Argument ~ ist keine Hash-Table."
  962.       //: ENGLISH "~: argument ~ is not a hash-table"
  963.       //: FRANCAIS "~: L'argument ~ n'est pas une table de hachage."
  964.       fehler(type_error, GETTEXT("~: argument ~ is not a hash-table"));
  965.     }
  966.  
  967. # (GETHASH key hashtable [default]), CLTL S. 284
  968. LISPFUN(gethash,2,1,norest,nokey,0,NIL)
  969.   { var reg1 object ht = STACK_1; # hashtable-Argument
  970.     if (!hash_table_p(ht)) { fehler_hashtable(ht); } # überprüfen
  971.    {var object* KVptr;
  972.     var object* Nptr;
  973.     var object* Iptr;
  974.     # Key STACK_2 in der Hash-Tabelle suchen:
  975.     if (hash_lookup(ht,STACK_2,&KVptr,&Nptr,&Iptr))
  976.       # gefunden -> Value als Wert:
  977.       { value1 = KVptr[1]; value2 = T; mv_count=2; # und T als 2. Wert
  978.         skipSTACK(3);
  979.       }
  980.       else
  981.       # nicht gefunden -> default oder NIL als Wert
  982.       { var reg2 object def = popSTACK(); # default
  983.         value1 = (eq(def,unbound) ? NIL : def); value2 = NIL; mv_count=2; # NIL als 2. Wert
  984.         skipSTACK(2);
  985.       }
  986.   }}
  987.  
  988. # (SYSTEM::PUTHASH key hashtable value) =
  989. # (SETF (GETHASH key hashtable) value), CLTL S. 284
  990. LISPFUNN(puthash,3)
  991.   { var reg1 object ht = STACK_1; # hashtable-Argument
  992.     if (!hash_table_p(ht)) { fehler_hashtable(ht); } # überprüfen
  993.    {var object* KVptr;
  994.     var object* Nptr;
  995.     var object* Iptr;
  996.     # Key STACK_2 in der Hash-Tabelle suchen:
  997.     if (hash_lookup(ht,STACK_2,&KVptr,&Nptr,&Iptr))
  998.       # gefunden -> Value ersetzen:
  999.       { value1 = KVptr[1] = popSTACK(); mv_count=1; skipSTACK(2); }
  1000.       else
  1001.       # nicht gefunden -> neuen Eintrag basteln:
  1002.       { var reg2 object freelist;
  1003.         hash_prepare_store(STACK_2);
  1004.         hash_store(STACK_2,STACK_0); # Eintrag basteln
  1005.         value1 = popSTACK(); mv_count=1; # value als Wert
  1006.         skipSTACK(2);
  1007.       }
  1008.   }}
  1009.  
  1010. # UP: Sucht ein Key in einer Hash-Tabelle und liefert den vorigen Wert.
  1011. # shifthash(ht,obj,value) == (SHIFTF (GETHASH obj ht) value)
  1012. # > ht: Hash-Tabelle
  1013. # > obj: Objekt
  1014. # > value: neuer Wert
  1015. # < ergebnis: alter Wert
  1016. # kann GC auslösen
  1017.   global object shifthash (object ht, object obj, object value);
  1018.   global object shifthash(ht,obj,value)
  1019.     var reg1 object ht;
  1020.     var reg3 object obj;
  1021.     var reg4 object value;
  1022.     { var object* KVptr;
  1023.       var object* Nptr;
  1024.       var object* Iptr;
  1025.       # Key obj in der Hash-Tabelle suchen:
  1026.       if (hash_lookup(ht,obj,&KVptr,&Nptr,&Iptr))
  1027.         # gefunden -> Value ersetzen:
  1028.         { var reg2 object oldvalue = KVptr[1];
  1029.           KVptr[1] = value;
  1030.           return oldvalue;
  1031.         }
  1032.         else
  1033.         # nicht gefunden -> neuen Eintrag basteln:
  1034.         { pushSTACK(obj); pushSTACK(value); # Key und Value retten
  1035.          {var reg2 object freelist;
  1036.           hash_prepare_store(STACK_1);
  1037.           hash_store(STACK_1,STACK_0); # Eintrag basteln
  1038.           skipSTACK(2);
  1039.           return NIL; # Default für den alten Wert ist NIL
  1040.         }}
  1041.     }
  1042.  
  1043. # (REMHASH key hashtable), CLTL S. 284
  1044. LISPFUNN(remhash,2)
  1045.   { var reg1 object ht = popSTACK(); # hashtable-Argument
  1046.     if (!hash_table_p(ht)) { fehler_hashtable(ht); } # überprüfen
  1047.    {var reg2 object key = popSTACK(); # key-Argument
  1048.     var object* KVptr;
  1049.     var object* Nptr;
  1050.     var object* Iptr;
  1051.     # Key in der Hash-Tabelle suchen:
  1052.     if (hash_lookup(ht,key,&KVptr,&Nptr,&Iptr))
  1053.       # gefunden -> aus der Hashtabelle streichen:
  1054.       { var reg3 object index = *Iptr; # Index im Next-Vektor
  1055.         # mit Nptr = &TheSvector(TheHashtable(ht)->ht_ntable)->data[index]
  1056.         # und KVptr = &TheSvector(TheHashtable(ht)->ht_kvtable)->data[2*index]
  1057.         set_break_sem_2(); # Vor Unterbrechungen schützen
  1058.         *Iptr = *Nptr; # "Liste" verkürzen
  1059.         *KVptr++ = leer; *KVptr = leer; # Key und Value leeren
  1060.         # Freiliste verlängern:
  1061.         *Nptr = TheHashtable(ht)->ht_freelist;
  1062.         TheHashtable(ht)->ht_freelist = index;
  1063.         # COUNT decrementieren:
  1064.         TheHashtable(ht)->ht_count = fixnum_inc(TheHashtable(ht)->ht_count,-1);
  1065.         clr_break_sem_2(); # Unterbrechungen wieder zulassen
  1066.         # Bei COUNT < MINCOUNT die Hash-Tabelle verkleinern:
  1067.         if (posfixnum_to_L(TheHashtable(ht)->ht_count) < posfixnum_to_L(TheHashtable(ht)->ht_mincount))
  1068.           # Hash-Tabelle verkleinern:
  1069.           { # maxcount := (max (floor (/ maxcount rehash-size)) 1)
  1070.             pushSTACK(ht); # Hashtable retten
  1071.             pushSTACK(TheHashtable(ht)->ht_maxcount);
  1072.             pushSTACK(TheHashtable(ht)->ht_rehash_size); # REHASH-SIZE (>1)
  1073.             funcall(L(durch),2); # (/ maxcount rehash-size), ist < maxcount
  1074.             pushSTACK(value1);
  1075.             funcall(L(floor),1); # (floor ...), ein Integer >=0, < maxcount
  1076.            {var reg4 object maxcount = value1;
  1077.             if (eq(maxcount,Fixnum_0)) { maxcount = Fixnum_1; } # aus 0 mache 1
  1078.             resize(popSTACK(),maxcount); # Tabelle verkleinern
  1079.           }}
  1080.         value1 = T; mv_count=1; # T als Wert
  1081.       }
  1082.       else
  1083.       # nicht gefunden
  1084.       { value1 = NIL; mv_count=1; } # NIL als Wert
  1085.   }}
  1086.  
  1087. # (MAPHASH function hashtable), CLTL S. 285
  1088. LISPFUNN(maphash,2)
  1089.   { var reg3 object ht = STACK_0; # hashtable-Argument
  1090.     if (!hash_table_p(ht)) { fehler_hashtable(ht); } # überprüfen
  1091.     # Durch den Key-Value-Vektor von hinten durchlaufen und
  1092.     # für alle Key-Value-Paare mit Key /= "leer" die Funktion aufrufen:
  1093.    {var reg2 uintL index = 2*posfixnum_to_L(TheHashtable(ht)->ht_maxcount);
  1094.     STACK_0 = TheHashtable(ht)->ht_kvtable; # Key-Value-Vektor
  1095.     # Stackaufbau: function, Key-Value-Vektor.
  1096.     loop
  1097.       { if (index==0) break;
  1098.         index -= 2;
  1099.        {var reg1 object* KVptr = &TheSvector(STACK_0)->data[index];
  1100.         if (!eq(KVptr[0],leer)) # Key /= "leer" ?
  1101.           { pushSTACK(KVptr[0]); # Key als 1. Argument
  1102.             pushSTACK(KVptr[1]); # Value als 2. Argument
  1103.             funcall(STACK_(1+2),2); # (FUNCALL function Key Value)
  1104.       }}  }
  1105.     skipSTACK(2);
  1106.     value1 = NIL; mv_count=1; # NIL als Wert
  1107.   }}
  1108.  
  1109. # (CLRHASH hashtable), CLTL S. 285
  1110. LISPFUNN(clrhash,1)
  1111.   { var reg1 object ht = popSTACK(); # hashtable-Argument
  1112.     if (!hash_table_p(ht)) { fehler_hashtable(ht); } # überprüfen
  1113.     clrhash(ht); # Tabelle leeren
  1114.     # Bei MINCOUNT > 0 die Hash-Tabelle verkleinern:
  1115.     if (!eq(TheHashtable(ht)->ht_mincount,Fixnum_0))
  1116.       { ht = resize(ht,Fixnum_1); } # auf MAXCOUNT:=1 verkleinern, so daß MINCOUNT:=0
  1117.     value1 = ht; mv_count=1; # Hash-Tabelle als Wert
  1118.   }
  1119.  
  1120. # (HASH-TABLE-COUNT hashtable), CLTL S. 285, CLtL2 S. 439
  1121. LISPFUNN(hash_table_count,1)
  1122.   { var reg1 object ht = popSTACK(); # hashtable-Argument
  1123.     if (!hash_table_p(ht)) { fehler_hashtable(ht); } # überprüfen
  1124.     value1 = TheHashtable(ht)->ht_count; mv_count=1; # Fixnum COUNT als Wert
  1125.   }
  1126.  
  1127. # (HASH-TABLE-REHASH-SIZE hashtable), CLtL2 S. 441, dpANS p. 18-7
  1128. LISPFUNN(hash_table_rehash_size,1)
  1129.   { var reg1 object ht = popSTACK(); # hashtable-Argument
  1130.     if (!hash_table_p(ht)) { fehler_hashtable(ht); } # überprüfen
  1131.     value1 = TheHashtable(ht)->ht_rehash_size; mv_count=1; # Short-Float REHASH-SIZE als Wert
  1132.   }
  1133.  
  1134. # (HASH-TABLE-REHASH-THRESHOLD hashtable), CLtL2 S. 441, dpANS p. 18-8
  1135. LISPFUNN(hash_table_rehash_threshold,1)
  1136.   { var reg1 object ht = popSTACK(); # hashtable-Argument
  1137.     if (!hash_table_p(ht)) { fehler_hashtable(ht); } # überprüfen
  1138.     # Da MAKE-HASH-TABLE das :REHASH-THRESHOLD Argument ignoriert, ist der
  1139.     # Wert hier egal und willkürlich.
  1140.     value1 = make_SF(0,SF_exp_mid+0,(bit(SF_mant_len)/2)*3); mv_count=1; # 0.75s0 als Wert
  1141.   }
  1142.  
  1143. # (HASH-TABLE-SIZE hashtable), CLtL2 S. 441, dpANS p. 18-9
  1144. LISPFUNN(hash_table_size,1)
  1145.   { var reg1 object ht = popSTACK(); # hashtable-Argument
  1146.     if (!hash_table_p(ht)) { fehler_hashtable(ht); } # überprüfen
  1147.     value1 = TheHashtable(ht)->ht_maxcount; mv_count=1; # Fixnum MAXCOUNT als Wert
  1148.   }
  1149.  
  1150. # (HASH-TABLE-TEST hashtable), CLtL2 S. 441, dpANS p. 18-9
  1151. LISPFUNN(hash_table_test,1)
  1152.   { var reg1 object ht = popSTACK(); # hashtable-Argument
  1153.     if (!hash_table_p(ht)) { fehler_hashtable(ht); } # überprüfen
  1154.    {var reg2 uintB flags = TheHashtable(ht)->recflags;
  1155.     value1 = (flags & bit(0) ? S(eq) : # EQ
  1156.               flags & bit(1) ? S(eql) : # EQL
  1157.               flags & bit(2) ? S(equal) : # EQUAL
  1158.               NIL /*NOTREACHED*/
  1159.              );
  1160.     mv_count=1; # Symbol als Wert
  1161.   }}
  1162.  
  1163. # Hilfsfunktionen für WITH-HASH-TABLE-ITERATOR, CLTL2 S. 439:
  1164. # (SYSTEM::HASH-TABLE-ITERATOR hashtable) liefert einen internen Zustand
  1165. # für das Iterieren durch eine Hash-Tabelle.
  1166. # (SYSTEM::HASH-TABLE-ITERATE internal-state) iteriert durch eine Hash-Tabelle
  1167. # um eins weiter, verändert dabei internal-state und liefert: 3 Werte
  1168. # T, key, value des nächsten Hash-Tabellen-Eintrags bzw. 1 Wert NIL am Schluß.
  1169.  
  1170. LISPFUNN(hash_table_iterator,1)
  1171.   { var reg1 object ht = STACK_0; # hashtable-Argument
  1172.     if (!hash_table_p(ht)) { fehler_hashtable(ht); } # überprüfen
  1173.     # Ein interner Zustand besteht aus dem Key-Value-Vektor und einem Index.
  1174.     STACK_0 = TheHashtable(ht)->ht_kvtable; # Key-Value-Vektor
  1175.    {var reg3 object maxcount = TheHashtable(ht)->ht_maxcount; # maxcount
  1176.     var reg2 object state = allocate_cons();
  1177.     Car(state) = popSTACK(); # Key-Value-Vektor als Car
  1178.     Cdr(state) = maxcount; # maxcount als Cdr
  1179.     value1 = state; mv_count=1; # state als Wert
  1180.   }}
  1181.  
  1182. LISPFUNN(hash_table_iterate,1)
  1183.   { var reg1 object state = popSTACK(); # interner Zustand
  1184.     if (consp(state)) # hoffentlich ein Cons
  1185.       { var reg4 object table = Car(state); # Key-Value-Vektor
  1186.         loop
  1187.           { var reg3 uintL index = posfixnum_to_L(Cdr(state));
  1188.             if (index==0) break; # index=0 -> keine Elemente mehr
  1189.             Cdr(state) = fixnum_inc(Cdr(state),-1); # Index decrementieren
  1190.            {var reg2 object* KVptr = &TheSvector(table)->data[2*index-2];
  1191.             if (!eq(KVptr[0],leer)) # Key /= "leer" ?
  1192.               { value2 = KVptr[0]; # Key als 2. Wert
  1193.                 value3 = KVptr[1]; # Value als 3. Wert
  1194.                 value1 = T; mv_count=3; return;
  1195.       }   }}  }
  1196.     value1 = NIL; mv_count=1; return; # 1 Wert NIL
  1197.   }
  1198.  
  1199. # (CLOS::CLASS-GETHASH ht object) ist wie (GETHASH (CLASS-OF object) ht).
  1200. LISPFUNN(class_gethash,2)
  1201.   { var reg1 object ht = STACK_1; # hashtable-Argument
  1202.     if (!hash_table_p(ht)) { fehler_hashtable(ht); } # überprüfen
  1203.     C_class_of(); # value1 := (CLASS-OF object)
  1204.    {var object* KVptr;
  1205.     var object* Nptr;
  1206.     var object* Iptr;
  1207.     # Key value1 in der Hash-Tabelle suchen:
  1208.     if (hash_lookup(ht,value1,&KVptr,&Nptr,&Iptr))
  1209.       # gefunden -> Value als Wert:
  1210.       { value1 = KVptr[1]; value2 = T; mv_count=2; } # und T als 2. Wert
  1211.       else
  1212.       # nicht gefunden -> NIL als Wert
  1213.       { value1 = NIL; value2 = NIL; mv_count=2; } # NIL als 2. Wert
  1214.     skipSTACK(1);
  1215.   }}
  1216.  
  1217. # (CLOS::CLASS-TUPLE-GETHASH ht object1 ... objectn)
  1218. # ist wie (GETHASH (funcall (hash-tuple-function n) class1 ... classn) ht)
  1219. # mit classi = (CLASS-OF objecti).
  1220. # Dabei sei n>0, ht eine EQUAL-Hashtabelle und (hash-tuple-function n) wie in
  1221. # clos.lsp definiert.
  1222. # Diese Funktion ist der Kern des Dispatch für generische Funktionen. Sie soll
  1223. # darum schnell sein und nicht consen.
  1224.   # Für 1 < n <= 16 ist
  1225.   #   (hash-tuple-function n ...) =
  1226.   #   (cons (hash-tuple-function n1 ...) (hash-tuple-function n2 ...))
  1227.     local uintC tuple_half_1 [17] = {0,0,1,1,2,2,2,3,4,4,4,4,4,5,6,7,8};
  1228.     local uintC tuple_half_2 [17] = {0,0,1,2,2,3,4,4,4,5,6,7,8,8,8,8,8};
  1229.   # Hilfsfunktion: Hashcode einer Reihe von Atomen berechnen, so als wären
  1230.   # sie per (hash-tuple-function n) zusammengeconst:
  1231.     local uint32 hashcode_tuple (uintC n, object* args_pointer, uintC depth);
  1232.     local uint32 hashcode_tuple(n,args_pointer,depth)
  1233.       var reg2 uintC n; # n > 0
  1234.       var reg1 object* args_pointer;
  1235.       var reg4 uintC depth;
  1236.       { if (n==1)
  1237.           { return hashcode1(Next(args_pointer)); } # hashcode_atom für Klassen
  1238.         elif (n<=16)
  1239.           { var reg6 uintC n1 = tuple_half_1[n];
  1240.             var reg7 uintC n2 = tuple_half_2[n]; # n1 + n2 = n
  1241.             var reg3 uint32 code1 = hashcode_tuple(n1,args_pointer,depth+1);
  1242.             var reg5 uint32 code2 = hashcode_tuple(n2,args_pointer STACKop -(uintP)n1,depth+1);
  1243.             switch (depth)
  1244.               { case 0: code1 = rotate_left(16,code1); break;
  1245.                 case 1: code1 = rotate_left(7,code1); break; # vgl. hashcode_cons3
  1246.                 case 2: code1 = rotate_left(5,code1); break; # vgl. hashcode_cons2
  1247.                 case 3: code1 = rotate_left(3,code1); break; # vgl. hashcode_cons1
  1248.                 default: NOTREACHED
  1249.               }
  1250.             return code1 ^ code2;
  1251.           }
  1252.         else # n>16, depth=0
  1253.           { var reg8 uint32 code1 = hashcode_tuple(8,args_pointer,1);
  1254.             var reg7 uint32 code2 = hashcode_tuple(4,args_pointer STACKop -8,2);
  1255.             var reg6 uint32 code3 = hashcode_tuple(2,args_pointer STACKop -12,3);
  1256.             var reg5 uint32 code4 = hashcode_tuple(1,args_pointer STACKop -14,4);
  1257.             var reg4 uint32 code = 1; # vgl. hashcode_cons0
  1258.             code = rotate_left(3,code4) ^ code; # vgl. hashcode_cons1
  1259.             code = rotate_left(5,code3) ^ code; # vgl. hashcode_cons2
  1260.             code = rotate_left(7,code2) ^ code; # vgl. hashcode_cons3
  1261.             code = rotate_left(16,code1) ^ code;
  1262.             return code;
  1263.       }   }
  1264.   # Hilfsfunktion: Vergleich eines Objekts mit einer Reihe von Atomen, so als
  1265.   # wären sie per (hash-tuple-function n) zusammengeconst:
  1266.     local boolean equal_tuple (object obj, uintC n, object* args_pointer);
  1267.     local boolean equal_tuple(obj,n,args_pointer)
  1268.       var reg1 object obj;
  1269.       var reg2 uintC n; # n > 0
  1270.       var reg3 object* args_pointer;
  1271.       { if (n==1)
  1272.           { if (eq(obj,Next(args_pointer)))
  1273.               { return TRUE; }
  1274.               else
  1275.               { return FALSE; }
  1276.           }
  1277.         elif (n<=16)
  1278.           { if (consp(obj))
  1279.               { var reg4 uintC n1 = tuple_half_1[n];
  1280.                 var reg5 uintC n2 = tuple_half_2[n]; # n1 + n2 = n
  1281.                 if (equal_tuple(Car(obj),n1,args_pointer)
  1282.                     && equal_tuple(Cdr(obj),n2,args_pointer STACKop -(uintP)n1)
  1283.                    )
  1284.                   return TRUE;
  1285.               }
  1286.             return FALSE;
  1287.           }
  1288.         else # n>16
  1289.           { if (consp(obj) && equal_tuple(Car(obj),8,args_pointer))
  1290.               { obj = Cdr(obj);
  1291.                 if (consp(obj) && equal_tuple(Car(obj),4,args_pointer STACKop -8))
  1292.                   { obj = Cdr(obj);
  1293.                     if (consp(obj) && equal_tuple(Car(obj),2,args_pointer STACKop -12))
  1294.                       { obj = Cdr(obj);
  1295.                         n-=14; args_pointer skipSTACKop -14;
  1296.                         # obj mit einer Liste der weiteren Atome vergleichen:
  1297.                         dotimespC(n,n,
  1298.                           { if (!(consp(obj) && eq(Car(obj),Next(args_pointer))))
  1299.                               return FALSE;
  1300.                             obj = Cdr(obj); args_pointer skipSTACKop -1;
  1301.                           });
  1302.                         if (nullp(obj))
  1303.                           # Vergleich erfüllt
  1304.                           { return TRUE; }
  1305.               }   }   }
  1306.             return FALSE;
  1307.       }   }
  1308.  
  1309. LISPFUN(class_tuple_gethash,2,0,rest,nokey,0,NIL)
  1310. { argcount++; rest_args_pointer skipSTACKop 1; # Argumente: ht {object}+
  1311.   # Zuerst CLASS-OF auf die einzelnen Argumente anwenden:
  1312.   { var reg1 object* arg_pointer = rest_args_pointer;
  1313.     var reg2 uintC count;
  1314.     dotimespC(count,argcount,
  1315.       { pushSTACK(Next(arg_pointer)); C_class_of(); # (CLASS-OF arg)
  1316.         NEXT(arg_pointer) = value1; # =: arg
  1317.       });
  1318.   }
  1319.  {var reg1 object ht = Before(rest_args_pointer); # hashtable-Argument
  1320.   if (!hash_table_p(ht)) { fehler_hashtable(ht); } # überprüfen
  1321.   if (!ht_validp(TheHashtable(ht)))
  1322.     # Hash-Tabelle muß erst noch reorganisiert werden
  1323.     { rehash(ht); }
  1324.   { var reg7 uint32 code = # Hashcode des Cons-Baumes berechnen
  1325.       hashcode_tuple(argcount,rest_args_pointer,0);
  1326.     var reg6 uintL hashindex;
  1327.     divu_3232_3232(code,posfixnum_to_L(TheHashtable(ht)->ht_size),_EMA_,hashindex = );
  1328.    {var reg2 object* Nptr = # Pointer auf den aktuellen Eintrag
  1329.       &TheSvector(TheHashtable(ht)->ht_itable)->data[hashindex];
  1330.     loop
  1331.       { # "Liste" weiterverfolgen:
  1332.         if (eq(*Nptr,nix)) break; # "Liste" zu Ende -> nicht gefunden
  1333.         { var reg3 uintL index = posfixnum_to_L(*Nptr); # nächster Index
  1334.           Nptr = # Pointer auf Eintrag im Next-Vektor
  1335.             &TheSvector(TheHashtable(ht)->ht_ntable)->data[index];
  1336.          {var reg4 object* KVptr = # Pointer auf Einträge im Key-Value-Vektor
  1337.             &TheSvector(TheHashtable(ht)->ht_kvtable)->data[2*index];
  1338.           if (equal_tuple(KVptr[0],argcount,rest_args_pointer)) # Key vergleichen
  1339.             # gefunden
  1340.             { value1 = KVptr[1]; goto fertig; } # Value als Wert
  1341.       } }}
  1342.   }}
  1343.   # nicht gefunden
  1344.   value1 = NIL;
  1345.   fertig:
  1346.   mv_count=1;
  1347.   set_args_end_pointer(rest_args_pointer STACKop 1); # STACK aufräumen
  1348. }}
  1349.  
  1350. # UP: Berechnet einen portablen EQUAL-Hashcode eines Objekts.
  1351. # sxhash(obj)
  1352. # Er ist nur bis zur nächsten Modifizierung des Objekts gültig.
  1353. # Aus (equal X Y) folgt (= (sxhash X) (sxhash Y)).
  1354. # > obj: ein Objekt
  1355. # < ergebnis: Hashcode, eine 32-Bit-Zahl
  1356.   local uint32 sxhash (object obj);
  1357. # Hilfsfunktionen bei bekanntem Typ:
  1358.   # Atom -> Fallunterscheidung nach Typ
  1359.   local uint32 sxhash_atom (object obj);
  1360.   local uint32 sxhash_atom(obj)
  1361.     var reg1 object obj;
  1362.     { switch (typecode(obj)) # je nach Typ
  1363.         { case_symbol: # Symbol
  1364.             # Printname verwerten
  1365.             # (nicht auch die Home-Package, da sie sich bei UNINTERN verändert)
  1366.             return hashcode_string(Symbol_name(obj))+0x339B0E4CUL;
  1367.           case_machine: # Maschinenpointer
  1368.           default:
  1369.             # Adresse darf nicht verwendet werden, nur den Typ verwerten
  1370.             return highlow32(typecode(obj),0xDABE); # Typinfo*2^16+Kennung
  1371.           case_bvector: # bit-vector
  1372.             # Bit-Vektor-Inhalt
  1373.             return hashcode_bvector(obj);
  1374.           case_string: # String
  1375.             # String-Inhalt
  1376.             return hashcode_string(obj);
  1377.           case_svector: # Simple-Vector
  1378.             # nur die Länge verwerten
  1379.             return TheSvector(obj)->length + 0x4ECD0A9FUL;
  1380.           case_ovector: # (vector t)
  1381.           case_array1: # allgemeiner Array
  1382.             # mehrdimensionaler Array -> nur Rang verwerten
  1383.             return TheArray(obj)->rank + 0xAAFAFAAEUL;
  1384.           case_structure: # Structure
  1385.             # nur Structure-Typ (Liste (name_1 name_2 ... . name_n)) verwerten
  1386.             { check_SP();
  1387.               return sxhash(TheStructure(obj)->structure_types) + 0xAD2CD2AEUL;
  1388.             }
  1389.           case_stream: # Stream
  1390.             # nur Streamtyp verwerten
  1391.             return TheStream(obj)->strmtype + 0x3DAEAE55UL;
  1392.          {var reg3 uint32 bish_code;
  1393.           case_closure: # Closure
  1394.             # alle Elemente verwerten ??
  1395.             bish_code = 0xB0DD939EUL; goto record_all;
  1396.           case_orecord: # OtherRecord
  1397.             # Record-Typ verwerten, außerdem:
  1398.             # Package: Package-Name verwerten (nicht ganz OK, da eine
  1399.             #          Package mit RENAME-PACKAGE umbenannt werden kann!)
  1400.             # Pathname, Byte, LoadTimeEval: alle Komponenten verwerten
  1401.             # Hash-Table, Readtable, Random-State, Symbol-Macro: nichts weiter
  1402.             { var reg6 sintB rectype = TheRecord(obj)->rectype;
  1403.               #ifndef case_structure
  1404.               if (rectype == Rectype_Structure) goto case_structure;
  1405.               #endif
  1406.               #ifndef case_stream
  1407.               if (rectype == Rectype_Stream) goto case_stream;
  1408.               #endif
  1409.               bish_code = 0xB04D939EUL + rectype;
  1410.               if (rectype == Rectype_Package) # Package ?
  1411.                 # Package-Name verwerten
  1412.                 { var reg4 uint32 next_code = hashcode_string(ThePackage(obj)->pack_name);
  1413.                   return rotate_left(1,next_code) + bish_code;
  1414.                 }
  1415.               elif (rectype == Rectype_Fsubr) # Fsubr ?
  1416.                 # Namen verwerten
  1417.                 { check_SP(); return sxhash(TheFsubr(obj)->name) + 0xFF3319BAUL; }
  1418.               elif ((rectype == Rectype_Pathname) # Pathname ?
  1419.                     #ifdef LOGICAL_PATHNAMES
  1420.                     || (rectype == Rectype_Logpathname) # Pathname ?
  1421.                     #endif
  1422.                     || (rectype == Rectype_Byte) # Byte ?
  1423.                     || (rectype == Rectype_Loadtimeeval) # LoadTimeEval ?
  1424.                    )
  1425.                 goto record_all;
  1426.               else
  1427.                 { return bish_code; }
  1428.             }
  1429.           record_all:
  1430.             #  Record, in dem man alle Elemente verwerten kann
  1431.             check_SP();
  1432.             { var reg2 object* ptr = &TheRecord(obj)->recdata[0];
  1433.               var reg5 uintC count = Record_length(obj);
  1434.               dotimespC(count,count,
  1435.                 # Hashcode der nächsten Komponente dazunehmen:
  1436.                 { var reg4 uint32 next_code = sxhash(*ptr++);
  1437.                   bish_code = misch(bish_code,next_code);
  1438.                 });
  1439.               return bish_code;
  1440.             }
  1441.          }
  1442.           case_instance: # Instanz
  1443.             # nur Klasse verwerten
  1444.             return sxhash(TheInstance(obj)->class) + 0x61EFA249;
  1445.           case_char: # Character
  1446.             # EQ-Hashcode nehmen (bei Characters ist ja EQUAL == EQL == EQ)
  1447.             return hashcode1(obj);
  1448.           case_subr: # SUBR
  1449.             # Namen verwerten
  1450.             check_SP(); return sxhash(TheSubr(obj)->name) + 0xFF3319BAUL;
  1451.           case_system: # Frame-Pointer, Read-Label, System
  1452.             # Adresse verwenden
  1453.             return hashcode1(obj);
  1454.           # Zahlen: nach Inhalt, wie bei EQL
  1455.           case_fixnum: # Fixnum
  1456.             return hashcode_fixnum(obj);
  1457.           case_bignum: # Bignum
  1458.             return hashcode_bignum(obj);
  1459.           case_sfloat: # Short-Float
  1460.             return hashcode_sfloat(obj);
  1461.           case_ffloat: # Single-Float
  1462.             return hashcode_ffloat(obj);
  1463.           case_dfloat: # Double-Float
  1464.             return hashcode_dfloat(obj);
  1465.           case_lfloat: # Long-Float
  1466.             return hashcode_lfloat(obj);
  1467.           case_ratio: # Ratio
  1468.             # beide Komponenten hashen, mischen
  1469.             { var reg2 uint32 code1 = sxhash(TheRatio(obj)->rt_num);
  1470.               var reg3 uint32 code2 = sxhash(TheRatio(obj)->rt_den);
  1471.               return misch(code1,code2);
  1472.             }
  1473.           case_complex: # Complex
  1474.             # beide Komponenten hashen, mischen
  1475.             { var reg2 uint32 code1 = sxhash(TheComplex(obj)->c_real);
  1476.               var reg3 uint32 code2 = sxhash(TheComplex(obj)->c_imag);
  1477.               return misch(code1,code2);
  1478.             }
  1479.     }   }
  1480. # Cons -> Inhalt bis zur Tiefe 4 ansehen:
  1481. # Jeweils Hashcode des CAR und Hashcode des CDR bestimmen
  1482. # und geshiftet kombinieren. Als Shifts passen z.B. 16,7,5,3,
  1483. # 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}
  1484. # aus 16 verschiedenen Elementen von {0,...,31} besteht.
  1485.   # Objekt, bei Cons nur bis Tiefe 0
  1486.   local uint32 sxhash_cons0 (object obj);
  1487.   local uint32 sxhash_cons0(obj)
  1488.     var reg1 object obj;
  1489.     { if (atomp(obj))
  1490.         { return sxhash_atom(obj); }
  1491.         else
  1492.         # Cons -> Hashcode := 1
  1493.         { return 1; }
  1494.     }
  1495.   # Objekt, bei Cons nur bis Tiefe 1
  1496.   local uint32 sxhash_cons1 (object obj);
  1497.   local uint32 sxhash_cons1(obj)
  1498.     var reg1 object obj;
  1499.     { if (atomp(obj))
  1500.         { return sxhash_atom(obj); }
  1501.         else
  1502.         # Cons -> Hashcode des CAR und des CDR bestimmen und mischen:
  1503.         { var reg2 uint32 code1 = sxhash_cons0(Car(obj));
  1504.           var reg3 uint32 code2 = sxhash_cons0(Cdr(obj));
  1505.           return rotate_left(3,code1) ^ code2;
  1506.     }   }
  1507.   # Objekt, bei Cons nur bis Tiefe 2
  1508.   local uint32 sxhash_cons2 (object obj);
  1509.   local uint32 sxhash_cons2(obj)
  1510.     var reg1 object obj;
  1511.     { if (atomp(obj))
  1512.         { return sxhash_atom(obj); }
  1513.         else
  1514.         # Cons -> Hashcode des CAR und des CDR bestimmen und mischen:
  1515.         { var reg2 uint32 code1 = sxhash_cons1(Car(obj));
  1516.           var reg3 uint32 code2 = sxhash_cons1(Cdr(obj));
  1517.           return rotate_left(5,code1) ^ code2;
  1518.     }   }
  1519.   # Objekt, bei Cons nur bis Tiefe 3
  1520.   local uint32 sxhash_cons3 (object obj);
  1521.   local uint32 sxhash_cons3(obj)
  1522.     var reg1 object obj;
  1523.     { if (atomp(obj))
  1524.         { return sxhash_atom(obj); }
  1525.         else
  1526.         # Cons -> Hashcode des CAR und des CDR bestimmen und mischen:
  1527.         { var reg2 uint32 code1 = sxhash_cons2(Car(obj));
  1528.           var reg3 uint32 code2 = sxhash_cons2(Cdr(obj));
  1529.           return rotate_left(7,code1) ^ code2;
  1530.     }   }
  1531.   # Objekt, bei Cons nur bis Tiefe 4
  1532.   local uint32 sxhash(obj)
  1533.     var reg1 object obj;
  1534.     { if (atomp(obj))
  1535.         { return sxhash_atom(obj); }
  1536.         else
  1537.         # Cons -> Hashcode des CAR und des CDR bestimmen und mischen:
  1538.         { var reg2 uint32 code1 = sxhash_cons3(Car(obj));
  1539.           var reg3 uint32 code2 = sxhash_cons3(Cdr(obj));
  1540.           return rotate_left(16,code1) ^ code2;
  1541.     }   }
  1542.  
  1543. # (SXHASH object), CLTL S. 285
  1544. LISPFUNN(sxhash,1)
  1545.   { value1 = UL_to_I(sxhash(popSTACK())); mv_count=1; } # Hashcode als Integer
  1546.  
  1547.