1 /* -*-C-*-
2
3 Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
4 1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
5 2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014 Massachusetts
6 Institute of Technology
7
8 This file is part of MIT/GNU Scheme.
9
10 MIT/GNU Scheme is free software; you can redistribute it and/or modify
11 it under the terms of the GNU General Public License as published by
12 the Free Software Foundation; either version 2 of the License, or (at
13 your option) any later version.
14
15 MIT/GNU Scheme is distributed in the hope that it will be useful, but
16 WITHOUT ANY WARRANTY; without even the implied warranty of
17 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
18 General Public License for more details.
19
20 You should have received a copy of the GNU General Public License
21 along with MIT/GNU Scheme; if not, write to the Free Software
22 Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
23 USA.
24
25 */
26
27 /* String primitives. */
28
29 #include "scheme.h"
30 #include "prims.h"
31
32 SCHEME_OBJECT
allocate_string(unsigned long nbytes)33 allocate_string (unsigned long nbytes)
34 {
35 SCHEME_OBJECT result
36 = (allocate_non_marked_vector (TC_CHARACTER_STRING,
37 (STRING_LENGTH_TO_GC_LENGTH (nbytes)),
38 true));
39 SET_STRING_LENGTH (result, nbytes);
40 return (result);
41 }
42
43 SCHEME_OBJECT
allocate_string_no_gc(unsigned long nbytes)44 allocate_string_no_gc (unsigned long nbytes)
45 {
46 SCHEME_OBJECT result
47 = (allocate_non_marked_vector (TC_CHARACTER_STRING,
48 (STRING_LENGTH_TO_GC_LENGTH (nbytes)),
49 false));
50 SET_STRING_LENGTH (result, nbytes);
51 return (result);
52 }
53
54 SCHEME_OBJECT
memory_to_string(unsigned long n_bytes,const void * vp)55 memory_to_string (unsigned long n_bytes, const void * vp)
56 {
57 SCHEME_OBJECT result = (allocate_string (n_bytes));
58 memcpy ((STRING_POINTER (result)), vp, n_bytes);
59 return (result);
60 }
61
62 SCHEME_OBJECT
memory_to_string_no_gc(unsigned long n_bytes,const void * vp)63 memory_to_string_no_gc (unsigned long n_bytes, const void * vp)
64 {
65 SCHEME_OBJECT result = (allocate_string_no_gc (n_bytes));
66 memcpy ((STRING_POINTER (result)), vp, n_bytes);
67 return (result);
68 }
69
70 SCHEME_OBJECT
char_pointer_to_string(const char * cp)71 char_pointer_to_string (const char * cp)
72 {
73 return (memory_to_string (((cp == 0) ? 0 : (strlen (cp))), cp));
74 }
75
76 SCHEME_OBJECT
char_pointer_to_string_no_gc(const char * cp)77 char_pointer_to_string_no_gc (const char * cp)
78 {
79 const char * scan = cp;
80 if (scan == 0)
81 scan += 1;
82 else
83 while ((*scan++) != '\0')
84 ;
85 return (memory_to_string_no_gc (((scan - 1) - cp), cp));
86 }
87
88 /* Currently the strings used in symbols have type codes in the length
89 field. They should be changed to have just longwords there. */
90
91 DEFINE_PRIMITIVE ("STRING-ALLOCATE", Prim_string_allocate, 1, 1, 0)
92 {
93 PRIMITIVE_HEADER (1);
94 PRIMITIVE_RETURN (allocate_string (arg_nonnegative_integer (1)));
95 }
96
97 DEFINE_PRIMITIVE ("STRING?", Prim_string_p, 1, 1, 0)
98 {
99 PRIMITIVE_HEADER (1);
100 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (STRING_P (ARG_REF (1))));
101 }
102
103 DEFINE_PRIMITIVE ("STRING-LENGTH", Prim_string_length, 1, 1, 0)
104 {
105 PRIMITIVE_HEADER (1);
106 CHECK_ARG (1, STRING_P);
107 PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (STRING_LENGTH (ARG_REF (1))));
108 }
109
110 DEFINE_PRIMITIVE ("STRING-MAXIMUM-LENGTH", Prim_string_maximum_length, 1, 1, 0)
111 {
112 PRIMITIVE_HEADER (1);
113 CHECK_ARG (1, STRING_P);
114 PRIMITIVE_RETURN
115 (LONG_TO_UNSIGNED_FIXNUM (MAXIMUM_STRING_LENGTH (ARG_REF (1))));
116 }
117
118 DEFINE_PRIMITIVE ("SET-STRING-LENGTH!", Prim_set_string_length, 2, 2, 0)
119 {
120 PRIMITIVE_HEADER (2);
121 CHECK_ARG (1, STRING_P);
122 {
123 SCHEME_OBJECT string = (ARG_REF (1));
124 SET_STRING_LENGTH
125 (string,
126 (arg_index_integer (2, ((MAXIMUM_STRING_LENGTH (string)) + 1))));
127 }
128 PRIMITIVE_RETURN (UNSPECIFIC);
129 }
130
131 DEFINE_PRIMITIVE ("SET-STRING-MAXIMUM-LENGTH!", Prim_set_string_maximum_length, 2, 2, 0)
132 {
133 PRIMITIVE_HEADER (2);
134 CHECK_ARG (1, STRING_P);
135 {
136 SCHEME_OBJECT string = (ARG_REF (1));
137 long length
138 = (arg_index_integer (2, ((MAXIMUM_STRING_LENGTH (string)) + 1)));
139 if (length < (STRING_LENGTH (string)))
140 SET_STRING_LENGTH (string, length);
141 MEMORY_SET
142 (string,
143 STRING_HEADER,
144 (MAKE_OBJECT
145 (TC_MANIFEST_NM_VECTOR, ((BYTES_TO_WORDS (length + 1)) + 1))));
146 }
147 PRIMITIVE_RETURN (UNSPECIFIC);
148 }
149
150 #define STRING_REF_BODY(process_result) \
151 { \
152 PRIMITIVE_HEADER (2); \
153 CHECK_ARG (1, STRING_P); \
154 { \
155 SCHEME_OBJECT string = (ARG_REF (1)); \
156 PRIMITIVE_RETURN \
157 (process_result \
158 (STRING_REF \
159 (string, (arg_index_integer (2, (STRING_LENGTH (string))))))); \
160 } \
161 }
162
163 DEFINE_PRIMITIVE ("STRING-REF", Prim_string_ref, 2, 2, 0)
STRING_REF_BODY(ASCII_TO_CHAR)164 STRING_REF_BODY (ASCII_TO_CHAR)
165
166 DEFINE_PRIMITIVE ("VECTOR-8B-REF", Prim_vec_8b_ref, 2, 2, 0)
167 STRING_REF_BODY (LONG_TO_UNSIGNED_FIXNUM)
168
169 #define STRING_SET_BODY(get_ascii) \
170 { \
171 PRIMITIVE_HEADER (3); \
172 CHECK_ARG (1, STRING_P); \
173 { \
174 SCHEME_OBJECT string = (ARG_REF (1)); \
175 STRING_SET \
176 (string, \
177 (arg_index_integer (2, (STRING_LENGTH (string)))), \
178 ((unsigned char) (get_ascii (3)))); \
179 } \
180 PRIMITIVE_RETURN (UNSPECIFIC); \
181 }
182
183 DEFINE_PRIMITIVE ("STRING-SET!", Prim_string_set, 3, 3, 0)
184 STRING_SET_BODY (arg_ascii_char)
185
186 DEFINE_PRIMITIVE ("VECTOR-8B-SET!", Prim_vec_8b_set, 3, 3, 0)
187 STRING_SET_BODY (arg_ascii_integer)
188
189 #define SUBSTRING_MOVE_PREFIX() \
190 unsigned char *ptr1, *ptr2; \
191 unsigned long len1, len2; \
192 unsigned long start1, end1, start2, end2, length; \
193 unsigned char *scan1, *scan2, *limit; \
194 PRIMITIVE_HEADER (5); \
195 ptr1 = (arg_extended_string (1, (&len1))); \
196 end1 = (arg_ulong_index_integer (3, (len1 + 1))); \
197 start1 = (arg_ulong_index_integer (2, (end1 + 1))); \
198 ptr2 = (arg_extended_string (4, (&len2))); \
199 start2 = (arg_ulong_index_integer (5, (len2 + 1))); \
200 length = (end1 - start1); \
201 end2 = (start2 + length); \
202 if (end2 > len2) \
203 error_bad_range_arg (5)
204
205 DEFINE_PRIMITIVE ("SUBSTRING-MOVE-RIGHT!", Prim_substring_move_right, 5, 5, 0)
206 {
207 SUBSTRING_MOVE_PREFIX ();
208 scan1 = (ptr1 + end1);
209 scan2 = (ptr2 + end2);
210 limit = (scan1 - length);
211 while (scan1 > limit)
212 (*--scan2) = (*--scan1);
213 PRIMITIVE_RETURN (UNSPECIFIC);
214 }
215
216 DEFINE_PRIMITIVE ("SUBSTRING-MOVE-LEFT!", Prim_substring_move_left, 5, 5, 0)
217 {
218 SUBSTRING_MOVE_PREFIX ();
219 scan1 = (ptr1 + start1);
220 scan2 = (ptr2 + start2);
221 limit = (scan1 + length);
222 while (scan1 < limit)
223 (*scan2++) = (*scan1++);
224 PRIMITIVE_RETURN (UNSPECIFIC);
225 }
226
227 #define SUBSTRING_MODIFIER(char_map) \
228 { \
229 SCHEME_OBJECT string; \
230 long start, end; \
231 long length; \
232 unsigned char *scan, temp; \
233 PRIMITIVE_HEADER (3); \
234 CHECK_ARG (1, STRING_P); \
235 string = (ARG_REF (1)); \
236 start = (arg_nonnegative_integer (2)); \
237 end = (arg_nonnegative_integer (3)); \
238 if (end > (STRING_LENGTH (string))) \
239 error_bad_range_arg (3); \
240 if (start > end) \
241 error_bad_range_arg (2); \
242 length = (end - start); \
243 scan = (STRING_LOC (string, start)); \
244 while ((length--) > 0) \
245 { \
246 temp = (*scan); \
247 (*scan++) = ((unsigned char) (char_map (temp))); \
248 } \
249 PRIMITIVE_RETURN (UNSPECIFIC); \
250 }
251
252 DEFINE_PRIMITIVE ("SUBSTRING-UPCASE!", Prim_substring_upcase, 3, 3, 0)
SUBSTRING_MODIFIER(char_upcase)253 SUBSTRING_MODIFIER (char_upcase)
254
255 DEFINE_PRIMITIVE ("SUBSTRING-DOWNCASE!", Prim_substring_downcase, 3, 3, 0)
256 SUBSTRING_MODIFIER (char_downcase)
257
258 #define VECTOR_8B_SUBSTRING_PREFIX() \
259 unsigned long start, end, length, ascii; \
260 unsigned char *string_start, *scan, *limit; \
261 PRIMITIVE_HEADER (4); \
262 string_start = (arg_extended_string (1, (&length))); \
263 start = (arg_nonnegative_integer (2)); \
264 end = (arg_nonnegative_integer (3)); \
265 ascii = (arg_ascii_integer (4)); \
266 if (end > length) \
267 error_bad_range_arg (3); \
268 if (start > end) \
269 error_bad_range_arg (2)
270
271 #define VECTOR_8B_SUBSTRING_PREFIX_FORWARD() \
272 VECTOR_8B_SUBSTRING_PREFIX (); \
273 scan = (string_start + start); \
274 limit = (string_start + end);
275
276 #define VECTOR_8B_SUBSTRING_PREFIX_BACKWARD() \
277 VECTOR_8B_SUBSTRING_PREFIX (); \
278 scan = (string_start + end); \
279 limit = (string_start + start);
280
281 DEFINE_PRIMITIVE ("VECTOR-8B-FILL!", Prim_vec_8b_fill, 4, 4, 0)
282 {
283 VECTOR_8B_SUBSTRING_PREFIX_FORWARD ();
284 while (scan < limit)
285 (*scan++) = ((unsigned char) ascii);
286 PRIMITIVE_RETURN (UNSPECIFIC);
287 }
288
289 DEFINE_PRIMITIVE ("VECTOR-8B-FIND-NEXT-CHAR", Prim_vec_8b_find_next_char, 4, 4, 0)
290 {
291 VECTOR_8B_SUBSTRING_PREFIX_FORWARD ();
292 while (scan < limit)
293 if ((*scan++) == ascii)
294 PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM ((scan - 1) - string_start));
295 PRIMITIVE_RETURN (SHARP_F);
296 }
297
298 DEFINE_PRIMITIVE ("VECTOR-8B-FIND-PREVIOUS-CHAR", Prim_vec_8b_find_prev_char, 4, 4, 0)
299 {
300 VECTOR_8B_SUBSTRING_PREFIX_BACKWARD ();
301 while (scan > limit)
302 if ((*--scan) == ascii)
303 PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (scan - string_start));
304 PRIMITIVE_RETURN (SHARP_F);
305 }
306
307 DEFINE_PRIMITIVE ("VECTOR-8B-FIND-NEXT-CHAR-CI", Prim_vec_8b_find_next_char_ci, 4, 4, 0)
308 {
309 VECTOR_8B_SUBSTRING_PREFIX_FORWARD ();
310 {
311 unsigned char char1 = ((unsigned char) (char_upcase (ascii)));
312 while (scan < limit)
313 if ((char_upcase (*scan++)) == char1)
314 PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM ((scan - 1) - string_start));
315 }
316 PRIMITIVE_RETURN (SHARP_F);
317 }
318
319 DEFINE_PRIMITIVE ("VECTOR-8B-FIND-PREVIOUS-CHAR-CI", Prim_vec_8b_find_prev_char_ci, 4, 4, 0)
320 {
321 VECTOR_8B_SUBSTRING_PREFIX_BACKWARD ();
322 {
323 unsigned char char1 = ((unsigned char) (char_upcase (ascii)));
324 while (scan > limit)
325 if ((char_upcase (*--scan)) == char1)
326 PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (scan - string_start));
327 }
328 PRIMITIVE_RETURN (SHARP_F);
329 }
330
331 #define SUBSTR_FIND_CHAR_IN_SET_PREFIX() \
332 unsigned long start, end, length; \
333 unsigned char *char_set, *string_start, *scan, *limit; \
334 PRIMITIVE_HEADER (4); \
335 string_start = (arg_extended_string (1, (&length))); \
336 start = (arg_nonnegative_integer (2)); \
337 end = (arg_nonnegative_integer (3)); \
338 CHECK_ARG (4, STRING_P); \
339 char_set = (STRING_LOC ((ARG_REF (4)), 0)); \
340 if (end > length) \
341 error_bad_range_arg (3); \
342 if (start > end) \
343 error_bad_range_arg (2); \
344 if ((STRING_LENGTH (ARG_REF (4))) != MAX_ASCII) \
345 error_bad_range_arg (4)
346
347 DEFINE_PRIMITIVE ("SUBSTRING-FIND-NEXT-CHAR-IN-SET", Prim_find_next_char_in_set, 4, 4, 0)
348 {
349 SUBSTR_FIND_CHAR_IN_SET_PREFIX ();
350 scan = (string_start + start);
351 limit = (string_start + end);
352 while (scan < limit)
353 if ((char_set [*scan++]) != '\0')
354 PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM ((scan - 1) - string_start));
355 PRIMITIVE_RETURN (SHARP_F);
356 }
357
358 DEFINE_PRIMITIVE ("SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET", Prim_find_prev_char_in_set, 4, 4, 0)
359 {
360 SUBSTR_FIND_CHAR_IN_SET_PREFIX ();
361 scan = (string_start + end);
362 limit = (string_start + start);
363 while (scan > limit)
364 if ((char_set [*--scan]) != '\0')
365 PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (scan - string_start));
366 PRIMITIVE_RETURN (SHARP_F);
367 }
368
369 #define SUBSTRING_COMPARE_PREFIX() \
370 long start1, end1, start2, end2; \
371 unsigned char *string1_start, *string2_start; \
372 PRIMITIVE_HEADER (6); \
373 CHECK_ARG (1, STRING_P); \
374 string1_start = (STRING_LOC ((ARG_REF (1)), 0)); \
375 start1 = (arg_nonnegative_integer (2)); \
376 end1 = (arg_nonnegative_integer (3)); \
377 CHECK_ARG (4, STRING_P); \
378 string2_start = (STRING_LOC ((ARG_REF (4)), 0)); \
379 start2 = (arg_nonnegative_integer (5)); \
380 end2 = (arg_nonnegative_integer (6)); \
381 if (end1 > (STRING_LENGTH (ARG_REF (1)))) \
382 error_bad_range_arg (3); \
383 if (start1 > end1) \
384 error_bad_range_arg (2); \
385 if (end2 > (STRING_LENGTH (ARG_REF (4)))) \
386 error_bad_range_arg (6); \
387 if (start2 > end2) \
388 error_bad_range_arg (5)
389
390 #define SUBSTRING_EQUAL_PREFIX() \
391 unsigned char *scan1, *scan2, *limit; \
392 SUBSTRING_COMPARE_PREFIX (); \
393 if ((end1 - start1) != (end2 - start2)) \
394 PRIMITIVE_RETURN (SHARP_F); \
395 scan1 = (string1_start + start1); \
396 limit = (string1_start + end1); \
397 scan2 = (string2_start + start2)
398
399 DEFINE_PRIMITIVE ("SUBSTRING=?", Prim_substring_equal, 6, 6, 0)
400 {
401 SUBSTRING_EQUAL_PREFIX ();
402 while (scan1 < limit)
403 if ((*scan1++) != (*scan2++))
404 PRIMITIVE_RETURN (SHARP_F);
405 PRIMITIVE_RETURN (SHARP_T);
406 }
407
408 DEFINE_PRIMITIVE ("SUBSTRING-CI=?", Prim_substring_ci_equal, 6, 6, 0)
409 {
410 SUBSTRING_EQUAL_PREFIX ();
411 while (scan1 < limit)
412 if ((char_upcase (*scan1++)) != (char_upcase (*scan2++)))
413 PRIMITIVE_RETURN (SHARP_F);
414 PRIMITIVE_RETURN (SHARP_T);
415 }
416
417 DEFINE_PRIMITIVE ("SUBSTRING<?", Prim_substring_less, 6, 6, 0)
418 {
419 SUBSTRING_COMPARE_PREFIX ();
420 {
421 unsigned char * scan1 = (string1_start + start1);
422 unsigned char * scan2 = (string2_start + start2);
423 long length1 = (end1 - start1);
424 long length2 = (end2 - start2);
425 unsigned char * limit =
426 (scan1 + ((length1 < length2) ? length1 : length2));
427 while (scan1 < limit)
428 if ((*scan1++) != (*scan2++))
429 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((scan1 [-1]) < (scan2 [-1])));
430 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (length1 < length2));
431 }
432 }
433
434 static long
substring_length_min(long start1,long end1,long start2,long end2)435 substring_length_min (long start1,
436 long end1,
437 long start2,
438 long end2)
439 {
440 long length1 = (end1 - start1);
441 long length2 = (end2 - start2);
442 return ((length1 < length2) ? length1 : length2);
443 }
444
445 #define SUBSTRING_MATCH_PREFIX() \
446 unsigned char *scan1, *scan2, *limit; \
447 long length; \
448 unsigned char *scan1_start; \
449 SUBSTRING_COMPARE_PREFIX (); \
450 length = (substring_length_min (start1, end1, start2, end2))
451
452 DEFINE_PRIMITIVE ("SUBSTRING-MATCH-FORWARD", Prim_match_forward, 6, 6, 0)
453 {
454 SUBSTRING_MATCH_PREFIX ();
455 scan1 = (string1_start + start1);
456 scan2 = (string2_start + start2);
457 limit = (scan1 + length);
458 scan1_start = scan1;
459 while (scan1 < limit)
460 if ((*scan1++) != (*scan2++))
461 PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM ((scan1 - 1) - scan1_start));
462 PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (length));
463 }
464
465 DEFINE_PRIMITIVE ("SUBSTRING-MATCH-FORWARD-CI", Prim_match_forward_ci, 6, 6, 0)
466 {
467 SUBSTRING_MATCH_PREFIX ();
468 scan1 = (string1_start + start1);
469 scan2 = (string2_start + start2);
470 limit = (scan1 + length);
471 scan1_start = scan1;
472 while (scan1 < limit)
473 if ((char_upcase (*scan1++)) != (char_upcase (*scan2++)))
474 PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM ((scan1 - 1) - scan1_start));
475 PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (length));
476 }
477
478 DEFINE_PRIMITIVE ("SUBSTRING-MATCH-BACKWARD", Prim_match_backward, 6, 6, 0)
479 {
480 SUBSTRING_MATCH_PREFIX ();
481 scan1 = (string1_start + end1);
482 scan2 = (string2_start + end2);
483 limit = (scan1 - length);
484 scan1_start = scan1;
485 while (scan1 > limit)
486 if ((*--scan1) != (*--scan2))
487 PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (scan1_start - (scan1 + 1)));
488 PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (length));
489 }
490
491 DEFINE_PRIMITIVE ("SUBSTRING-MATCH-BACKWARD-CI", Prim_match_backward_ci, 6, 6, 0)
492 {
493 SUBSTRING_MATCH_PREFIX ();
494 scan1 = (string1_start + end1);
495 scan2 = (string2_start + end2);
496 limit = (scan1 - length);
497 scan1_start = scan1;
498 while (scan1 > limit)
499 if ((char_upcase (*--scan1)) != (char_upcase (*--scan2)))
500 PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (scan1_start - (scan1 + 1)));
501 PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (length));
502 }
503
504 /* External strings */
505
506 /* An external string is just a chunk of memory allocated using malloc
507 outside of Scheme's address space. It is represented to Scheme as
508 an integer -- the address of the memory. Each external string is
509 registered in a hash table when it is allocated so that we can
510 validate the incoming integers. */
511
512 typedef struct ht_record_s ht_record_t;
513 struct ht_record_s
514 {
515 ht_record_t * next;
516 unsigned long n_bytes;
517 };
518
519 #define HT_RECORD_PTR(record) ((void *) ((record) + 1))
520 #define HT_RECORD_KEY(record) ((unsigned long) ((record) + 1))
521 #define HT_RECORD_NEXT(record) ((record) -> next)
522 #define HT_RECORD_N_BYTES(record) ((record) -> n_bytes)
523
524 typedef struct
525 {
526 unsigned long n_records;
527 unsigned long n_buckets;
528 ht_record_t ** buckets;
529 } hash_table_t;
530
531 #define HT_N_RECORDS(table) ((table) -> n_records)
532 #define HT_N_BUCKETS(table) ((table) -> n_buckets)
533 #define HT_BUCKET_INDEX(table, key) ((key) % (HT_N_BUCKETS (table)))
534 #define HT_BUCKETS(table) ((table) -> buckets)
535 #define HT_BUCKET_REF(table, index) ((HT_BUCKETS (table)) [(index)])
536 #define HT_SHRINK_POINT(table) ((((HT_N_BUCKETS (table)) + 1) / 2) - 1)
537
538 static hash_table_t * make_hash_table (void);
539 static void ht_resize (hash_table_t *, unsigned long);
540 static void zero_ht_buckets (hash_table_t *);
541 static ht_record_t * ht_records_list (hash_table_t *);
542 static ht_record_t * ht_lookup (hash_table_t *, unsigned long);
543 static unsigned long ht_insert (hash_table_t *, ht_record_t *);
544 static ht_record_t * ht_delete (hash_table_t *, unsigned long);
545
546 static hash_table_t * external_strings = 0;
547
548 DEFINE_PRIMITIVE ("ALLOCATE-EXTERNAL-STRING", Prim_alloc_external_string, 1, 1, 0)
549 {
550 PRIMITIVE_HEADER (1);
551 {
552 unsigned long n_bytes = (arg_ulong_integer (1));
553 ht_record_t * result = (malloc (n_bytes + 1 + (sizeof (ht_record_t))));
554 if (result == 0)
555 error_bad_range_arg (1);
556 if (external_strings == 0)
557 external_strings = (make_hash_table ());
558 (HT_RECORD_N_BYTES (result)) = n_bytes;
559 /* Guarantee zero termination in case used as C string. */
560 (((char *) (HT_RECORD_PTR (result))) [n_bytes]) = '\0';
561 PRIMITIVE_RETURN (ulong_to_integer (ht_insert (external_strings, result)));
562 }
563 }
564
565 DEFINE_PRIMITIVE ("EXTERNAL-STRING?", Prim_external_string_p, 1, 1, 0)
566 {
567 PRIMITIVE_HEADER (1);
568 {
569 SCHEME_OBJECT x = (ARG_REF (1));
570 if ((INTEGER_P (x)) && (integer_to_ulong_p (x)))
571 {
572 ht_record_t * record;
573 if (external_strings == 0)
574 external_strings = (make_hash_table ());
575 record = (ht_lookup (external_strings, (integer_to_ulong (x))));
576 PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (record != 0));
577 }
578 else
579 PRIMITIVE_RETURN (SHARP_F);
580 }
581 }
582
583 DEFINE_PRIMITIVE ("DEALLOCATE-EXTERNAL-STRING", Prim_dealloc_external_string, 1, 1, 0)
584 {
585 PRIMITIVE_HEADER (1);
586 {
587 unsigned long n = (arg_ulong_integer (1));
588 ht_record_t * record;
589 if (external_strings == 0)
590 external_strings = (make_hash_table ());
591 record = (ht_delete (external_strings, n));
592 if (record == 0)
593 error_wrong_type_arg (1);
594 free (record);
595 PRIMITIVE_RETURN (UNSPECIFIC);
596 }
597 }
598
599 DEFINE_PRIMITIVE ("EXTENDED-STRING-LENGTH", Prim_extended_string_length, 1, 1, 0)
600 {
601 PRIMITIVE_HEADER (1);
602 {
603 unsigned long len;
604 arg_extended_string (1, (&len));
605 PRIMITIVE_RETURN (ulong_to_integer (len));
606 }
607 }
608
609 unsigned char *
lookup_external_string(SCHEME_OBJECT descriptor,unsigned long * lp)610 lookup_external_string (SCHEME_OBJECT descriptor, unsigned long * lp)
611 {
612 ht_record_t * record;
613 if (external_strings == 0)
614 external_strings = (make_hash_table ());
615 record = (ht_lookup (external_strings, (integer_to_ulong (descriptor))));
616 if (record == 0)
617 return (0);
618 if (lp != 0)
619 (*lp) = (HT_RECORD_N_BYTES (record));
620 return (HT_RECORD_PTR (record));
621 }
622
623 unsigned char *
arg_extended_string(unsigned int n,unsigned long * lp)624 arg_extended_string (unsigned int n, unsigned long * lp)
625 {
626 SCHEME_OBJECT object = (ARG_REF (n));
627 if (STRING_P (object))
628 {
629 if (lp != 0)
630 (*lp) = (STRING_LENGTH (object));
631 return ((unsigned char *) (STRING_POINTER (object)));
632 }
633 else if ((INTEGER_P (object)) && (integer_to_ulong_p (object)))
634 {
635 unsigned char * result = (lookup_external_string (object, lp));
636 if (result == 0)
637 error_wrong_type_arg (n);
638 return (result);
639 }
640 else
641 {
642 error_wrong_type_arg (n);
643 return (0);
644 }
645 }
646
647 #define HT_MIN_EXPT 4
648 #define HT_MAX_EXPT 24
649
650 #define EXPT_TO_N(e) ((1 << (e)) - 1)
651
652 static hash_table_t *
make_hash_table(void)653 make_hash_table (void)
654 {
655 unsigned long n = (EXPT_TO_N (HT_MIN_EXPT));
656 hash_table_t * table = (malloc (sizeof (hash_table_t)));
657 if (table == 0)
658 abort ();
659 (HT_N_RECORDS (table)) = 0;
660 (HT_N_BUCKETS (table)) = n;
661 (HT_BUCKETS (table)) = (malloc (n * (sizeof (ht_record_t *))));
662 if ((HT_BUCKETS (table)) == 0)
663 abort ();
664 zero_ht_buckets (table);
665 return (table);
666 }
667
668 static void
ht_resize(hash_table_t * table,unsigned long new_n_buckets)669 ht_resize (hash_table_t * table,
670 unsigned long new_n_buckets)
671 {
672 ht_record_t ** new_buckets
673 = (malloc (new_n_buckets * (sizeof (ht_record_t *))));
674 if (new_buckets != 0)
675 {
676 ht_record_t * records = (ht_records_list (table));
677 (HT_BUCKETS (table)) = new_buckets;
678 (HT_N_BUCKETS (table)) = new_n_buckets;
679 (HT_N_RECORDS (table)) = 0;
680 zero_ht_buckets (table);
681 while (records != 0)
682 {
683 ht_record_t * next = (HT_RECORD_NEXT (records));
684 ht_insert (table, records);
685 records = next;
686 }
687 }
688 }
689
690 static void
zero_ht_buckets(hash_table_t * table)691 zero_ht_buckets (hash_table_t * table)
692 {
693 ht_record_t ** scan = (HT_BUCKETS (table));
694 ht_record_t ** end = (scan + (HT_N_BUCKETS (table)));
695 while (scan < end)
696 (*scan++) = 0;
697 }
698
699 static ht_record_t *
ht_records_list(hash_table_t * table)700 ht_records_list (hash_table_t * table)
701 {
702 ht_record_t ** scan_buckets = (HT_BUCKETS (table));
703 ht_record_t ** end_buckets = (scan_buckets + (HT_N_BUCKETS (table)));
704 ht_record_t * result = 0;
705 while (scan_buckets < end_buckets)
706 {
707 ht_record_t * scan = (*scan_buckets);
708 while (scan != 0)
709 {
710 ht_record_t * next = (HT_RECORD_NEXT (scan));
711 (HT_RECORD_NEXT (scan)) = result;
712 result = scan;
713 scan = next;
714 }
715 (*scan_buckets++) = 0;
716 }
717 return (result);
718 }
719
720 static ht_record_t *
ht_lookup(hash_table_t * table,unsigned long key)721 ht_lookup (hash_table_t * table,
722 unsigned long key)
723 {
724 unsigned long index = (HT_BUCKET_INDEX (table, key));
725 ht_record_t * record = (HT_BUCKET_REF (table, index));
726 while (record != 0)
727 {
728 if ((HT_RECORD_KEY (record)) == key)
729 return (record);
730 record = (HT_RECORD_NEXT (record));
731 }
732 return (0);
733 }
734
735 static unsigned long
ht_insert(hash_table_t * table,ht_record_t * record)736 ht_insert (hash_table_t * table,
737 ht_record_t * record)
738 {
739 unsigned long index = (HT_BUCKET_INDEX (table, (HT_RECORD_KEY (record))));
740 ht_record_t * scan = (HT_BUCKET_REF (table, index));
741 (HT_RECORD_NEXT (record)) = 0;
742 if (scan == 0)
743 (HT_BUCKET_REF (table, index)) = record;
744 else
745 {
746 while ((HT_RECORD_NEXT (scan)) != 0)
747 scan = (HT_RECORD_NEXT (scan));
748 (HT_RECORD_NEXT (scan)) = record;
749 }
750 (HT_N_RECORDS (table)) += 1;
751 if (((HT_N_RECORDS (table)) >= (HT_N_BUCKETS (table)))
752 && ((HT_N_BUCKETS (table)) < (EXPT_TO_N (HT_MAX_EXPT))))
753 {
754 unsigned int e = HT_MIN_EXPT;
755 while (e <= HT_MAX_EXPT)
756 {
757 unsigned long n = (EXPT_TO_N (e));
758 if (n > (HT_N_BUCKETS (table)))
759 {
760 ht_resize (table, n);
761 break;
762 }
763 e += 1;
764 }
765 }
766 return (HT_RECORD_KEY (record));
767 }
768
769 static ht_record_t *
ht_delete(hash_table_t * table,unsigned long key)770 ht_delete (hash_table_t * table,
771 unsigned long key)
772 {
773 unsigned long index = (HT_BUCKET_INDEX (table, key));
774 ht_record_t * scan = (HT_BUCKET_REF (table, index));
775 ht_record_t * prev = 0;
776 while (1)
777 {
778 if (scan == 0)
779 return (0);
780 if ((HT_RECORD_KEY (scan)) == key)
781 break;
782 prev = scan;
783 scan = (HT_RECORD_NEXT (scan));
784 }
785 if (prev == 0)
786 (HT_BUCKET_REF (table, index)) = (HT_RECORD_NEXT (scan));
787 else
788 (HT_RECORD_NEXT (prev)) = (HT_RECORD_NEXT (scan));
789 (HT_N_RECORDS (table)) -= 1;
790 if (((HT_N_RECORDS (table)) < (HT_SHRINK_POINT (table)))
791 && ((HT_N_BUCKETS (table)) > (EXPT_TO_N (HT_MIN_EXPT))))
792 {
793 unsigned int e = HT_MAX_EXPT;
794 while (e >= HT_MIN_EXPT)
795 {
796 unsigned long n = (EXPT_TO_N (e));
797 if (n < (HT_N_BUCKETS (table)))
798 {
799 ht_resize (table, n);
800 break;
801 }
802 e -= 1;
803 }
804 }
805 return (scan);
806 }
807