mim/development/mim/mimc/hash.mud

   1 <PACKAGE "HASH">
   2
   3 <ENTRY HASH EXPAND-FLAG>
   4
   5 <SETG EXPAND-FLAG <>>
   6
   7 <SETG PFIX 0>
   8 <SETG PLIST 1>
   9 <SETG PRECORD 2>
  10 <SETG PBYTES 4>
  11 <SETG PSTRING 5>
  12 <SETG PUVECTOR 6>
  13 <SETG PVECTOR 7>
  14 <SETG ONE-IN-LH <LSH 1 16>>
  15 <MANIFEST PFIX PLIST PRECORD PBYTES PSTRING PUVECTOR PVECTOR ONE-IN-LH>
  16
  17 <DEFINE HASH (OBJ:ANY "OPT" (POS:FIX 0)
  18                       "AUX" HASH:FIX (FTYP:FIX <ANDB <CALL TYPE .OBJ> 7>)
  19                             PREHASH:FIX ATM (EXP-MACROS ,EXPAND-FLAG))
  20         <COND (<AND <TYPE? .OBJ FORM>
  21                     .EXP-MACROS
  22                     <NOT <EMPTY? .OBJ>>
  23                     <TYPE? <SET ATM <1 .OBJ>> ATOM>
  24                     <GASSIGNED? .ATM>>
  25                <COND (<AND <OR <==? .ATM GVAL> <==? .ATM LVAL>>
  26                            <NOT <EMPTY? <REST .OBJ>>>
  27                            <TYPE? <2 .OBJ> ATOM>>
  28                       <SET OBJ <CHTYPE <2 .OBJ> .ATM>>
  29                       <SET FTYP ,PRECORD>)
  30                      (<==? <GET-DECL <GBIND .ATM>> MANIFEST>
  31                       <SET PREHASH <HASH ,.ATM <+ .POS ,ONE-IN-LH>>>)
  32                      (<TYPE? ,.ATM MACRO>
  33                       <SET PREHASH <HASH <EXPAND .OBJ>
  34                                          <+ .POS ,ONE-IN-LH>>>)>)>
  35         <CASE ,==? .FTYP
  36               (,PFIX
  37                <SET HASH <CHTYPE .OBJ FIX>>)
  38               (,PSTRING
  39                <SET HASH <HASH-STRING <CHTYPE .OBJ STRING>
  40                                       <+ .POS ,ONE-IN-LH>>>)
  41               (,PLIST
  42                <SET HASH <HASH-LIST <CHTYPE .OBJ LIST> <+ .POS ,ONE-IN-LH>>>)
  43               (,PRECORD
  44                <COND (<AND .EXP-MACROS
  45                            <TYPE? .OBJ GVAL>
  46                            <GASSIGNED? <SET ATM <CHTYPE .OBJ ATOM>>>
  47                            <==? <GET-DECL <GBIND .ATM>> MANIFEST>>
  48                       <SET HASH <HASH ,.ATM <+ .POS ,ONE-IN-LH>>>)
  49                      (<OR <TYPE? .OBJ ATOM LVAL GVAL>
  50                           <==? <PRIMTYPE .OBJ> ATOM>>
  51                       <SET HASH <HASH-ATOM <CHTYPE .OBJ ATOM>
  52                                            <+ .POS ,ONE-IN-LH>>>)>)
  53               (,PBYTES
  54                <SET HASH <HASH-BYTES <CHTYPE .OBJ BYTES> <+ .POS ,ONE-IN-LH>>>)
  55               (,PVECTOR
  56                <SET HASH <HASH-VECTOR <CHTYPE .OBJ VECTOR>
  57                                       <+ .POS ,ONE-IN-LH>>>)
  58               (,PUVECTOR
  59                <SET HASH <HASH-UVECTOR <CHTYPE .OBJ UVECTOR>
  60                                        <+ .POS ,ONE-IN-LH>>>)
  61               DEFAULT
  62               (<ERROR UNKNOWN-PRIMTYPE!-ERRORS <PRIMTYPE .OBJ> HASH>)>
  63    <COND (<NEWTYPE? .OBJ>
  64           <SET HASH
  65                <XORB <ROT32 <CHTYPE <TYPE-C <PRIMTYPE .OBJ>> FIX> 13>
  66                      <HASH-ATOM <TYPE .OBJ> <+ .POS ,ONE-IN-LH>>
  67                      <ROT32 .HASH 17>>>)
  68          (ELSE
  69           <SET HASH <XORB <ROT32 .HASH 17> <CALL TYPE .OBJ>>>)>
  70    <COND (<ASSIGNED? PREHASH> <SET HASH <XORB <ROT32 .HASH 17> .PREHASH>>)>
  71    <XORB .HASH .POS>>
  72
  73 <DEFINE HASH-ATOM (ATM:ATOM POS:FIX)
  74    <COND (<==? .ATM ROOT>
  75           <XORB 82 .POS>)
  76          (ELSE
  77           <XORB <ROT32 <HASH-STRING <SPNAME .ATM> <+ .POS ,ONE-IN-LH>>
  78                      17>
  79                 <HASH <OBLIST? .ATM> <+ .POS ,ONE-IN-LH>>>)>>
  80
  81 <DEFINE HASH-STRING (STR:STRING POS:FIX "AUX" (HASH 0))
  82    #DECL ((HASH) FIX)
  83    <MAPF <>
  84          <FUNCTION (CH:CHARACTER)
  85             <SET HASH
  86                  <XORB
  87                   <ROT32 .HASH
  88                        17>
  89                   .POS
  90                   .CH>>
  91             <SET POS <+ .POS 1>>>
  92          .STR>
  93    .HASH>
  94
  95 ;<DEFINE CALL (A B)
  96    <CHTYPE
  97     <TYPE-C <TYPE .B>>
  98     FIX>>
  99
 100 <DEFINE HASH-LIST (LIST:LIST POS:FIX "AUX" (HASH 0))
 101    #DECL ((HASH) FIX)
 102    <MAPF <>
 103          <FUNCTION (ELEM:ANY)
 104             <SET HASH
 105                  <XORB
 106                   <ROT32 .HASH
 107                        17>
 108                   <HASH .ELEM <+ .POS ,ONE-IN-LH>>
 109                   .POS>>
 110             <SET POS <+ .POS 1>>>
 111          .LIST>
 112    .HASH>
 113
 114 <DEFINE HASH-VECTOR (VEC:VECTOR POS:FIX "AUX" (HASH 0))
 115    #DECL ((HASH) FIX)
 116    <MAPF <>
 117          <FUNCTION (ELEM:ANY)
 118             <SET HASH
 119                  <XORB
 120                   <ROT32 .HASH
 121                        17>
 122                   <HASH .ELEM <+ .POS ,ONE-IN-LH>>
 123                   .POS>>
 124             <SET POS <+ .POS 1>>>
 125          .VEC>
 126    .HASH>
 127
 128 <DEFINE HASH-UVECTOR (UVEC:UVECTOR POS:FIX "AUX" (HASH 0))
 129    #DECL ((HASH) FIX)
 130    <MAPF <>
 131          <FUNCTION (ELEM:ANY)
 132             <SET HASH
 133                  <XORB
 134                   <ROT32 .HASH
 135                        17>
 136                   .ELEM
 137                   .POS>>
 138             <SET POS <+ .POS 1>>>
 139          .UVEC>
 140    .HASH>
 141
 142 <DEFINE HASH-BYTES (BYT:BYTES POS:FIX "AUX" (HASH 0))
 143    #DECL ((HASH) FIX)
 144    <MAPF <>
 145          <FUNCTION (ELEM:FIX)
 146             <SET HASH
 147                  <XORB
 148                   <ROT32 .HASH
 149                        17>
 150                   .ELEM
 151                   .POS>>
 152             <SET POS <+ .POS 1>>>
 153          .BYT>
 154    .HASH>
 155
 156  <DEFINE NEWTYPE? (OBJ:ANY)
 157     <G? <LSH <CALL TYPE .OBJ> -6> ,OLD-TYPES>>
 158
 159 <ENDPACKAGE>