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 1983, Hewlett-Packard Company, see the file 11% HP_disclaimer at the root of the PSL file tree 12% 13%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 14% 15% Revisions: 16% 17% 31-Aug-88 (Julian Padget) 18% Changed first "fluid" call to "global" since there was no need of former. 19% 12-Dec-84 20:30 (Brian Beach) 20% Added missing STRINF in UNCHECKED-STRING-INTERN. 21% 13-Nov-84 14:03:50 (Brian Beach) 22% Added changes to include the PKG-FASL hack. Added function FASLIN-INTERN 23% which searches for a null in the name of an ID, and only looks at the part 24% of the name after the null. 25% 11-Jul-84 08:04:48 (Brian Beach) 26% Minor cleanup. 27% 28%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% 29 30 31(compiletime (load hash-decls f-strings)) 32 33(on fast-integers fast-strings) 34 35(global '(nextsymbol show-new-ids)) 36 37(de initialize-symbol-table () 38 % Initialize the symbol table. SYMNAM, SYMFNC, SYMVAL, and SYMPRP 39 % have been filled in for all defined symbols by the cross compiler. 40 % We need to create the linked list for the unused symbols in SYMNAM, 41 % and set up the hash table. 42 43 (for (from i nextsymbol maxsymbols) 44 (do (setf (symnam i) (+ i 1)))) 45 (setf (symnam maxsymbols) 0) 46 47 (for (from i 0 hash-table-size) 48 (do (setf (hash-table-entry i) empty-slot-value))) 49 (for (from i 128 (- 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 (let ((string-inf (strinf name)) 88 (string-len (strlen (strinf name))) 89 hash-table-index 90 bps-string 91 new-id) 92 (if (= string-len 0) 93 (mkid (strbyt string-inf 0)) 94 (if (occupied-slot? (setq hash-table-index (hash-into-table name))) 95 (mkid (hash-table-entry hash-table-index)) 96 (progn 97 (when show-new-ids 98 (console-print-string "New id: ") 99 (console-print-string name) 100 (console-newline) 101 ) 102 (setq new-id (gtid)) % allocate a new ID 103 (setf (hash-table-entry hash-table-index) new-id) % plant it in the hash table 104 (setq bps-string (gtconststr string-len)) % allocate a string from uncollected space 105 (copystringtofrom bps-string string-inf) 106 (initialize-new-id new-id (mkstr bps-string)) 107 ))))) 108 109(de hash-into-table (name) 110 % NAME is a string. Returns a hash table index. 111 (prog (hash-value walk-table del-slot) 112 (setf hash-value (hash-function name)) 113 (setf walk-table hash-value) 114 (setf del-slot -1) 115 loop 116 (cond ((empty-slot? walk-table) 117 (return (if (wneq del-slot -1) 118 del-slot 119 walk-table))) 120 ((deleted-slot? walk-table) 121 (when (weq del-slot -1) (setq del-slot walk-table))) 122 ((equal-hash-entry walk-table name) 123 (return walk-table))) 124 (setq walk-table (next-slot walk-table)) 125 (when (weq walk-table hash-value) 126 (kernel-fatal-error "Hash table overflow")) 127 (go loop))) 128 129(de initialize-new-id (id-number print-name) 130 % Initialize cells of an ID to defaults 131 (let ((id (mkid id-number))) 132 (setf (symnam id-number) print-name) 133 (setf (symprp id-number) nil) 134 (setf (symval id-number) (mkitem unbound-tag id-number)) 135 (plantunbound id-number) 136 id 137 )) 138 139(de hash-function (s) 140 % Compute hash function of string. The value is computed by folding together 141 % a bunch of bits from the first BITSPERWORD - 8 characters of the string. 142 143 (let* ((inf (strinf s)) 144 (len (strlen inf)) 145 (result 0)) 146 (when (> len (- bitsperword 8)) 147 (setq len (- bitsperword 8))) 148 (for (from i 0 len) 149 (do (setf result 150 (^ result (<< (strbyt inf i) 151 (- (- bitsperword 8) i)))))) 152 (wremainder result hash-table-size) 153 )) 154 155(off fast-integers) 156 157% End of file. 158