1%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 2% 3% File: PK:INTERN.SL 4% Description: Interning of symbols for the kernel. 5% Author: Brian Beach, Hewlett-Packard CRC 6% Created: 16-Feb-84 7% Modified: 13-Nov-84 14:35:11 (Brian Beach) 8% Package: 9% 10% (c) Copyright 1987, University of Utah, all rights reserved. 11% 12%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 13% 14% Revisions: 15% 16% 31-Aug-88 (Julian Padget) 17% Changed first "fluid" call to "global" since there was no need of former. 18% 12-Dec-84 20:30 (Brian Beach) 19% Added missing STRINF in UNCHECKED-STRING-INTERN. 20% 13-Nov-84 14:03:50 (Brian Beach) 21% Added changes to include the PKG-FASL hack. Added function FASLIN-INTERN 22% which searches for a null in the name of an ID, and only looks at the part 23% of the name after the null. 24% 11-Jul-84 08:04:48 (Brian Beach) 25% Minor cleanup. 26% 27%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 28 29 30(compiletime (load hash-decls f-strings)) 31 32(on fast-integers fast-strings) 33 34(global '(nextsymbol show-new-ids)) 35 36(de initialize-symbol-table () 37 % Initialize the symbol table. SYMNAM, SYMFNC, SYMVAL, and SYMPRP 38 % have been filled in for all defined symbols by the cross compiler. 39 % We need to create the linked list for the unused symbols in SYMNAM, 40 % and set up the hash table. 41 42 (for (from i nextsymbol maxsymbols) 43 (do (setf (symnam i) (+ i 1)))) 44 (setf (symnam maxsymbols) 0) 45 46 (for (from i 0 hash-table-size) 47 (do (setf (hash-table-entry i) empty-slot-value))) 48 (setf (hash-table-entry (hash-into-table (symnam 128))) 128) 49 (for (from i 256 (- nextsymbol 1)) % Don't intern single character IDs 50 (do (setf (hash-table-entry (hash-into-table (symnam i))) i))) 51 (setf show-new-ids nil) 52 ) 53 54(de faslin-intern (string) 55 56 % A simple routine to remove package information from the name being 57 % interned by FASLIN. This function will be redefined when the package 58 % system is loaded. 59 60 (let ((pos (search-string-for-character (char null) string))) 61 (if (not pos) 62 (intern string) 63 % else 64 (let ((bound (string-upper-bound string))) 65 (when (and (> bound pos) 66 (= (string-fetch string (+ pos 1)) (char null))) 67 % It's an internal symbol (two nulls in a row) 68 (setf pos (+ pos 1)) 69 ) 70 % Do something with case of nulls at end of string 71 % including the ID that has only null in its name. 72 (intern 73 (if (>= pos bound) 74 string 75 (subseq string (+ pos 1) (string-length string)) 76 )))))) 77 78(de intern (x) % To be redefined 79 (unchecked-string-intern x) 80 ) 81 82(de unchecked-string-intern (name) 83 % 84 % NAME is a String, which IS copied if it is not found on the hash table 85 % The interned ID with NAME as print name is returned. 86 % 87 88 (let ((string-inf (strinf name)) 89 (string-len (strlen (strinf name))) 90 hash-table-index 91 bps-string 92 new-id) 93 (if (= string-len 0) 94 (mkid (strbyt string-inf 0)) 95 (if (occupied-slot? (setq hash-table-index (hash-into-table name))) 96 (mkid (hash-table-entry hash-table-index)) 97 (progn 98 (when show-new-ids 99 (console-print-string "New id: ") 100 (console-print-string name) 101 (console-newline) 102 ) 103 (setq new-id (gtid)) % allocate a new ID 104 (setf (hash-table-entry hash-table-index) new-id) % plant it in the hash table 105 (setq bps-string (gtconststr string-len)) % allocate a string from uncollected space 106 (copystringtofrom bps-string string-inf) 107 108 (initialize-new-id new-id (mkstr bps-string)) 109 ))))) 110 111(de hash-into-table (name) 112 % NAME is a string. Returns a hash table index. 113 (prog (hash-value walk-table del-slot) 114 (setf hash-value (hash-function name)) 115 (setf walk-table hash-value) 116 (setf del-slot -1) 117 loop 118 (cond ((empty-slot? walk-table) 119 (return (if (wneq del-slot -1) 120 del-slot 121 walk-table))) 122 ((deleted-slot? walk-table) 123 (when (weq del-slot -1) (setq del-slot walk-table))) 124 ((equal-hash-entry walk-table name) 125 (return walk-table))) 126 (setq walk-table (next-slot walk-table)) 127 (when (weq walk-table hash-value) 128 (kernel-fatal-error (kernelstring2string "Hash table overflow"))) 129 (go loop))) 130 131(de initialize-new-id (id-number print-name) 132 % Initialize cells of an ID to defaults 133 (let ((id (mkid id-number))) 134 (setf (symnam id-number) print-name) 135 (setf (symprp id-number) nil) 136 (wputv symget id-number nil) 137 (setf (symval id-number) (mkitem unbound-tag id-number)) 138 (plantunbound id-number) 139 id 140 )) 141 142(de hash-function (s) 143 % Compute hash function of string. The value is computed by folding together 144 % a bunch of bits from the first BITSPERWORD - 8 characters of the string. 145 146 (let* ((inf (strinf s)) 147 (len (strlen inf)) 148 (result 0)) 149 (when (> len (- bitsperword 8)) 150 (setq len (- bitsperword 8))) 151 (for (from i 0 len) 152 (do (setf result 153 (^ result (<< (strbyt inf i) 154 (- (- bitsperword 8) i)))))) 155 (wremainder result hash-table-size) 156 )) 157 158(off fast-integers) 159 160% End of file. 161