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