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