/* -*-C-*-
$Id: string.c,v 9.47 2001/10/04 16:14:19 cph Exp $
Copyright (c) 1987-2001 Massachusetts Institute of Technology
This program is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.
This program is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.
*/
/* String primitives. */
#include "scheme.h"
#include "prims.h"
#ifndef STDC_HEADERS
# ifdef HAVE_MALLOC_H
# include <malloc.h>
# else
extern PTR EXFUN (malloc, (size_t));
extern PTR EXFUN (realloc, (PTR, size_t));
# endif
#endif
SCHEME_OBJECT
DEFUN (allocate_string, (nbytes), unsigned long nbytes)
{
SCHEME_OBJECT result
= (allocate_non_marked_vector
(TC_CHARACTER_STRING,
(STRING_LENGTH_TO_GC_LENGTH (nbytes)),
1));
SET_STRING_LENGTH (result, nbytes);
return (result);
}
SCHEME_OBJECT
DEFUN (allocate_string_no_gc, (nbytes), unsigned long nbytes)
{
SCHEME_OBJECT result
= (allocate_non_marked_vector
(TC_CHARACTER_STRING,
(STRING_LENGTH_TO_GC_LENGTH (nbytes)),
0));
SET_STRING_LENGTH (result, nbytes);
return (result);
}
SCHEME_OBJECT
DEFUN (memory_to_string, (nbytes, data),
unsigned long nbytes AND
CONST unsigned char * data)
{
SCHEME_OBJECT result = (allocate_string (nbytes));
unsigned char * scan_result = (STRING_LOC (result, 0));
unsigned char * end_result = (scan_result + nbytes);
while (scan_result < end_result)
(*scan_result++) = (*data++);
return (result);
}
SCHEME_OBJECT
DEFUN (memory_to_string_no_gc, (nbytes, data),
unsigned long nbytes AND
CONST unsigned char * data)
{
SCHEME_OBJECT result = (allocate_string_no_gc (nbytes));
unsigned char * scan_result = (STRING_LOC (result, 0));
unsigned char * end_result = (scan_result + nbytes);
while (scan_result < end_result)
(*scan_result++) = (*data++);
return (result);
}
SCHEME_OBJECT
DEFUN (char_pointer_to_string, (char_pointer),
CONST unsigned char * char_pointer)
{
CONST unsigned char * scan = char_pointer;
if (scan == 0)
scan += 1;
else
while ((*scan++) != '\0')
;
return (memory_to_string (((scan - 1) - char_pointer), char_pointer));
}
SCHEME_OBJECT
DEFUN (char_pointer_to_string_no_gc, (char_pointer),
CONST unsigned char * char_pointer)
{
CONST unsigned char * scan = char_pointer;
if (scan == 0)
scan += 1;
else
while ((*scan++) != '\0')
;
return (memory_to_string_no_gc (((scan - 1) - char_pointer), char_pointer));
}
/* Currently the strings used in symbols have type codes in the length
field. They should be changed to have just longwords there. */
DEFINE_PRIMITIVE ("STRING-ALLOCATE", Prim_string_allocate, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN (allocate_string (arg_nonnegative_integer (1)));
}
DEFINE_PRIMITIVE ("STRING?", Prim_string_p, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (STRING_P (ARG_REF (1))));
}
DEFINE_PRIMITIVE ("STRING-LENGTH", Prim_string_length, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
CHECK_ARG (1, STRING_P);
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (STRING_LENGTH (ARG_REF (1))));
}
DEFINE_PRIMITIVE ("STRING-MAXIMUM-LENGTH", Prim_string_maximum_length, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
CHECK_ARG (1, STRING_P);
PRIMITIVE_RETURN
(LONG_TO_UNSIGNED_FIXNUM (MAXIMUM_STRING_LENGTH (ARG_REF (1))));
}
DEFINE_PRIMITIVE ("SET-STRING-LENGTH!", Prim_set_string_length, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
CHECK_ARG (1, STRING_P);
{
SCHEME_OBJECT string = (ARG_REF (1));
SET_STRING_LENGTH
(string,
(arg_index_integer (2, ((MAXIMUM_STRING_LENGTH (string)) + 1))));
}
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("SET-STRING-MAXIMUM-LENGTH!", Prim_set_string_maximum_length, 2, 2, 0)
{
PRIMITIVE_HEADER (2);
CHECK_ARG (1, STRING_P);
{
SCHEME_OBJECT string = (ARG_REF (1));
long length
= (arg_index_integer (2, ((MAXIMUM_STRING_LENGTH (string)) + 1)));
if (length < (STRING_LENGTH (string)))
SET_STRING_LENGTH (string, length);
MEMORY_SET
(string,
STRING_HEADER,
(MAKE_OBJECT
(TC_MANIFEST_NM_VECTOR, ((BYTES_TO_WORDS (length + 1)) + 1))));
}
PRIMITIVE_RETURN (UNSPECIFIC);
}
#define STRING_REF_BODY(process_result) \
{ \
PRIMITIVE_HEADER (2); \
CHECK_ARG (1, STRING_P); \
{ \
SCHEME_OBJECT string = (ARG_REF (1)); \
PRIMITIVE_RETURN \
(process_result \
(STRING_REF \
(string, (arg_index_integer (2, (STRING_LENGTH (string))))))); \
} \
}
DEFINE_PRIMITIVE ("STRING-REF", Prim_string_ref, 2, 2, 0)
STRING_REF_BODY (ASCII_TO_CHAR)
DEFINE_PRIMITIVE ("VECTOR-8B-REF", Prim_vec_8b_ref, 2, 2, 0)
STRING_REF_BODY (LONG_TO_UNSIGNED_FIXNUM)
#define STRING_SET_BODY(get_ascii) \
{ \
PRIMITIVE_HEADER (3); \
CHECK_ARG (1, STRING_P); \
{ \
SCHEME_OBJECT string = (ARG_REF (1)); \
STRING_SET \
(string, \
(arg_index_integer (2, (STRING_LENGTH (string)))), \
((unsigned char) (get_ascii (3)))); \
} \
PRIMITIVE_RETURN (UNSPECIFIC); \
}
DEFINE_PRIMITIVE ("STRING-SET!", Prim_string_set, 3, 3, 0)
STRING_SET_BODY (arg_ascii_char)
DEFINE_PRIMITIVE ("VECTOR-8B-SET!", Prim_vec_8b_set, 3, 3, 0)
STRING_SET_BODY (arg_ascii_integer)
#define SUBSTRING_MOVE_PREFIX() \
unsigned char *ptr1, *ptr2; \
unsigned long len1, len2; \
unsigned long start1, end1, start2, end2, length; \
unsigned char *scan1, *scan2, *limit; \
PRIMITIVE_HEADER (5); \
ptr1 = (arg_extended_string (1, (&len1))); \
end1 = (arg_ulong_index_integer (3, (len1 + 1))); \
start1 = (arg_ulong_index_integer (2, (end1 + 1))); \
ptr2 = (arg_extended_string (4, (&len2))); \
start2 = (arg_ulong_index_integer (5, (len2 + 1))); \
length = (end1 - start1); \
end2 = (start2 + length); \
if (end2 > len2) \
error_bad_range_arg (5)
DEFINE_PRIMITIVE ("SUBSTRING-MOVE-RIGHT!", Prim_substring_move_right, 5, 5, 0)
{
SUBSTRING_MOVE_PREFIX ();
scan1 = (ptr1 + end1);
scan2 = (ptr2 + end2);
limit = (scan1 - length);
while (scan1 > limit)
(*--scan2) = (*--scan1);
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("SUBSTRING-MOVE-LEFT!", Prim_substring_move_left, 5, 5, 0)
{
SUBSTRING_MOVE_PREFIX ();
scan1 = (ptr1 + start1);
scan2 = (ptr2 + start2);
limit = (scan1 + length);
while (scan1 < limit)
(*scan2++) = (*scan1++);
PRIMITIVE_RETURN (UNSPECIFIC);
}
#define SUBSTRING_MODIFIER(char_map) \
{ \
SCHEME_OBJECT string; \
long start, end; \
long length; \
unsigned char *scan, temp; \
PRIMITIVE_HEADER (3); \
CHECK_ARG (1, STRING_P); \
string = (ARG_REF (1)); \
start = (arg_nonnegative_integer (2)); \
end = (arg_nonnegative_integer (3)); \
if (end > (STRING_LENGTH (string))) \
error_bad_range_arg (3); \
if (start > end) \
error_bad_range_arg (2); \
length = (end - start); \
scan = (STRING_LOC (string, start)); \
while ((length--) > 0) \
{ \
temp = (*scan); \
(*scan++) = ((unsigned char) (char_map (temp))); \
} \
PRIMITIVE_RETURN (UNSPECIFIC); \
}
DEFINE_PRIMITIVE ("SUBSTRING-UPCASE!", Prim_substring_upcase, 3, 3, 0)
SUBSTRING_MODIFIER (char_upcase)
DEFINE_PRIMITIVE ("SUBSTRING-DOWNCASE!", Prim_substring_downcase, 3, 3, 0)
SUBSTRING_MODIFIER (char_downcase)
#define VECTOR_8B_SUBSTRING_PREFIX() \
long start, end, ascii; \
unsigned char *string_start, *scan, *limit; \
PRIMITIVE_HEADER (4); \
CHECK_ARG (1, STRING_P); \
string_start = (STRING_LOC ((ARG_REF (1)), 0)); \
start = (arg_nonnegative_integer (2)); \
end = (arg_nonnegative_integer (3)); \
ascii = (arg_ascii_integer (4)); \
if (end > (STRING_LENGTH (ARG_REF (1)))) \
error_bad_range_arg (3); \
if (start > end) \
error_bad_range_arg (2)
#define VECTOR_8B_SUBSTRING_PREFIX_FORWARD() \
VECTOR_8B_SUBSTRING_PREFIX (); \
scan = (string_start + start); \
limit = (string_start + end);
#define VECTOR_8B_SUBSTRING_PREFIX_BACKWARD() \
VECTOR_8B_SUBSTRING_PREFIX (); \
scan = (string_start + end); \
limit = (string_start + start);
DEFINE_PRIMITIVE ("VECTOR-8B-FILL!", Prim_vec_8b_fill, 4, 4, 0)
{
VECTOR_8B_SUBSTRING_PREFIX_FORWARD ();
while (scan < limit)
(*scan++) = ((unsigned char) ascii);
PRIMITIVE_RETURN (UNSPECIFIC);
}
DEFINE_PRIMITIVE ("VECTOR-8B-FIND-NEXT-CHAR", Prim_vec_8b_find_next_char, 4, 4, 0)
{
VECTOR_8B_SUBSTRING_PREFIX_FORWARD ();
while (scan < limit)
if ((*scan++) == ascii)
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM ((scan - 1) - string_start));
PRIMITIVE_RETURN (SHARP_F);
}
DEFINE_PRIMITIVE ("VECTOR-8B-FIND-PREVIOUS-CHAR", Prim_vec_8b_find_prev_char, 4, 4, 0)
{
VECTOR_8B_SUBSTRING_PREFIX_BACKWARD ();
while (scan > limit)
if ((*--scan) == ascii)
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (scan - string_start));
PRIMITIVE_RETURN (SHARP_F);
}
DEFINE_PRIMITIVE ("VECTOR-8B-FIND-NEXT-CHAR-CI", Prim_vec_8b_find_next_char_ci, 4, 4, 0)
{
VECTOR_8B_SUBSTRING_PREFIX_FORWARD ();
{
unsigned char char1 = ((unsigned char) (char_upcase (ascii)));
while (scan < limit)
if ((char_upcase (*scan++)) == char1)
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM ((scan - 1) - string_start));
}
PRIMITIVE_RETURN (SHARP_F);
}
DEFINE_PRIMITIVE ("VECTOR-8B-FIND-PREVIOUS-CHAR-CI", Prim_vec_8b_find_prev_char_ci, 4, 4, 0)
{
VECTOR_8B_SUBSTRING_PREFIX_BACKWARD ();
{
unsigned char char1 = ((unsigned char) (char_upcase (ascii)));
while (scan > limit)
if ((char_upcase (*--scan)) == char1)
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (scan - string_start));
}
PRIMITIVE_RETURN (SHARP_F);
}
#define SUBSTR_FIND_CHAR_IN_SET_PREFIX() \
long start, end; \
unsigned char *char_set, *string_start, *scan, *limit; \
PRIMITIVE_HEADER (4); \
CHECK_ARG (1, STRING_P); \
string_start = (STRING_LOC ((ARG_REF (1)), 0)); \
start = (arg_nonnegative_integer (2)); \
end = (arg_nonnegative_integer (3)); \
CHECK_ARG (4, STRING_P); \
char_set = (STRING_LOC ((ARG_REF (4)), 0)); \
if (end > (STRING_LENGTH (ARG_REF (1)))) \
error_bad_range_arg (3); \
if (start > end) \
error_bad_range_arg (2); \
if ((STRING_LENGTH (ARG_REF (4))) != MAX_ASCII) \
error_bad_range_arg (4)
DEFINE_PRIMITIVE ("SUBSTRING-FIND-NEXT-CHAR-IN-SET", Prim_find_next_char_in_set, 4, 4, 0)
{
SUBSTR_FIND_CHAR_IN_SET_PREFIX ();
scan = (string_start + start);
limit = (string_start + end);
while (scan < limit)
if ((char_set [*scan++]) != '\0')
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM ((scan - 1) - string_start));
PRIMITIVE_RETURN (SHARP_F);
}
DEFINE_PRIMITIVE ("SUBSTRING-FIND-PREVIOUS-CHAR-IN-SET", Prim_find_prev_char_in_set, 4, 4, 0)
{
SUBSTR_FIND_CHAR_IN_SET_PREFIX ();
scan = (string_start + end);
limit = (string_start + start);
while (scan > limit)
if ((char_set [*--scan]) != '\0')
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (scan - string_start));
PRIMITIVE_RETURN (SHARP_F);
}
#define SUBSTRING_COMPARE_PREFIX() \
long start1, end1, start2, end2; \
unsigned char *string1_start, *string2_start; \
PRIMITIVE_HEADER (6); \
CHECK_ARG (1, STRING_P); \
string1_start = (STRING_LOC ((ARG_REF (1)), 0)); \
start1 = (arg_nonnegative_integer (2)); \
end1 = (arg_nonnegative_integer (3)); \
CHECK_ARG (4, STRING_P); \
string2_start = (STRING_LOC ((ARG_REF (4)), 0)); \
start2 = (arg_nonnegative_integer (5)); \
end2 = (arg_nonnegative_integer (6)); \
if (end1 > (STRING_LENGTH (ARG_REF (1)))) \
error_bad_range_arg (3); \
if (start1 > end1) \
error_bad_range_arg (2); \
if (end2 > (STRING_LENGTH (ARG_REF (4)))) \
error_bad_range_arg (6); \
if (start2 > end2) \
error_bad_range_arg (5)
#define SUBSTRING_EQUAL_PREFIX() \
unsigned char *scan1, *scan2, *limit; \
SUBSTRING_COMPARE_PREFIX (); \
if ((end1 - start1) != (end2 - start2)) \
PRIMITIVE_RETURN (SHARP_F); \
scan1 = (string1_start + start1); \
limit = (string1_start + end1); \
scan2 = (string2_start + start2)
DEFINE_PRIMITIVE ("SUBSTRING=?", Prim_substring_equal, 6, 6, 0)
{
SUBSTRING_EQUAL_PREFIX ();
while (scan1 < limit)
if ((*scan1++) != (*scan2++))
PRIMITIVE_RETURN (SHARP_F);
PRIMITIVE_RETURN (SHARP_T);
}
DEFINE_PRIMITIVE ("SUBSTRING-CI=?", Prim_substring_ci_equal, 6, 6, 0)
{
SUBSTRING_EQUAL_PREFIX ();
while (scan1 < limit)
if ((char_upcase (*scan1++)) != (char_upcase (*scan2++)))
PRIMITIVE_RETURN (SHARP_F);
PRIMITIVE_RETURN (SHARP_T);
}
DEFINE_PRIMITIVE ("SUBSTRING<?", Prim_substring_less, 6, 6, 0)
{
SUBSTRING_COMPARE_PREFIX ();
{
unsigned char * scan1 = (string1_start + start1);
unsigned char * scan2 = (string2_start + start2);
long length1 = (end1 - start1);
long length2 = (end2 - start2);
unsigned char * limit =
(scan1 + ((length1 < length2) ? length1 : length2));
while (scan1 < limit)
if ((*scan1++) != (*scan2++))
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT ((scan1 [-1]) < (scan2 [-1])));
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (length1 < length2));
}
}
static long
DEFUN (substring_length_min, (start1, end1, start2, end2),
long start1
AND long end1
AND long start2
AND long end2)
{
long length1 = (end1 - start1);
long length2 = (end2 - start2);
return ((length1 < length2) ? length1 : length2);
}
#define SUBSTRING_MATCH_PREFIX() \
unsigned char *scan1, *scan2, *limit; \
long length; \
unsigned char *scan1_start; \
SUBSTRING_COMPARE_PREFIX (); \
length = (substring_length_min (start1, end1, start2, end2))
DEFINE_PRIMITIVE ("SUBSTRING-MATCH-FORWARD", Prim_match_forward, 6, 6, 0)
{
SUBSTRING_MATCH_PREFIX ();
scan1 = (string1_start + start1);
scan2 = (string2_start + start2);
limit = (scan1 + length);
scan1_start = scan1;
while (scan1 < limit)
if ((*scan1++) != (*scan2++))
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM ((scan1 - 1) - scan1_start));
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (length));
}
DEFINE_PRIMITIVE ("SUBSTRING-MATCH-FORWARD-CI", Prim_match_forward_ci, 6, 6, 0)
{
SUBSTRING_MATCH_PREFIX ();
scan1 = (string1_start + start1);
scan2 = (string2_start + start2);
limit = (scan1 + length);
scan1_start = scan1;
while (scan1 < limit)
if ((char_upcase (*scan1++)) != (char_upcase (*scan2++)))
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM ((scan1 - 1) - scan1_start));
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (length));
}
DEFINE_PRIMITIVE ("SUBSTRING-MATCH-BACKWARD", Prim_match_backward, 6, 6, 0)
{
SUBSTRING_MATCH_PREFIX ();
scan1 = (string1_start + end1);
scan2 = (string2_start + end2);
limit = (scan1 - length);
scan1_start = scan1;
while (scan1 > limit)
if ((*--scan1) != (*--scan2))
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (scan1_start - (scan1 + 1)));
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (length));
}
DEFINE_PRIMITIVE ("SUBSTRING-MATCH-BACKWARD-CI", Prim_match_backward_ci, 6, 6, 0)
{
SUBSTRING_MATCH_PREFIX ();
scan1 = (string1_start + end1);
scan2 = (string2_start + end2);
limit = (scan1 - length);
scan1_start = scan1;
while (scan1 > limit)
if ((char_upcase (*--scan1)) != (char_upcase (*--scan2)))
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (scan1_start - (scan1 + 1)));
PRIMITIVE_RETURN (LONG_TO_UNSIGNED_FIXNUM (length));
}
/* External strings */
/* An external string is just a chunk of memory allocated using malloc
outside of Scheme's address space. It is represented to Scheme as
an integer -- the address of the memory. Each external string is
registered in a hash table when it is allocated so that we can
validate the incoming integers. */
typedef struct ht_record_s ht_record_t;
struct ht_record_s
{
ht_record_t * next;
unsigned long n_bytes;
};
#define HT_RECORD_PTR(record) ((PTR) ((record) + 1))
#define HT_RECORD_KEY(record) ((unsigned long) ((record) + 1))
#define HT_RECORD_NEXT(record) ((record) -> next)
#define HT_RECORD_N_BYTES(record) ((record) -> n_bytes)
typedef struct
{
unsigned long n_records;
unsigned long n_buckets;
ht_record_t ** buckets;
} hash_table_t;
#define HT_N_RECORDS(table) ((table) -> n_records)
#define HT_N_BUCKETS(table) ((table) -> n_buckets)
#define HT_BUCKET_INDEX(table, key) ((key) % (HT_N_BUCKETS (table)))
#define HT_BUCKETS(table) ((table) -> buckets)
#define HT_BUCKET_REF(table, index) ((HT_BUCKETS (table)) [(index)])
#define HT_SHRINK_POINT(table) ((((HT_N_BUCKETS (table)) + 1) / 2) - 1)
static hash_table_t * EXFUN (make_hash_table, (void));
static void EXFUN (ht_resize, (hash_table_t *, unsigned long));
static void EXFUN (zero_ht_buckets, (hash_table_t *));
static ht_record_t * EXFUN (ht_records_list, (hash_table_t *));
static ht_record_t * EXFUN (ht_lookup, (hash_table_t *, unsigned long));
static unsigned long EXFUN (ht_insert, (hash_table_t *, ht_record_t *));
static ht_record_t * EXFUN (ht_delete, (hash_table_t *, unsigned long));
static hash_table_t * external_strings = 0;
DEFINE_PRIMITIVE ("ALLOCATE-EXTERNAL-STRING", Prim_alloc_external_string, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
{
unsigned long n_bytes = (arg_ulong_integer (1));
ht_record_t * result = (malloc (n_bytes + 1 + (sizeof (ht_record_t))));
if (result == 0)
error_bad_range_arg (1);
if (external_strings == 0)
external_strings = (make_hash_table ());
(HT_RECORD_N_BYTES (result)) = n_bytes;
/* Guarantee zero termination in case used as C string. */
(((char *) (HT_RECORD_PTR (result))) [n_bytes]) = '\0';
PRIMITIVE_RETURN (ulong_to_integer (ht_insert (external_strings, result)));
}
}
DEFINE_PRIMITIVE ("EXTERNAL-STRING?", Prim_external_string_p, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
{
SCHEME_OBJECT x = (ARG_REF (1));
if ((INTEGER_P (x)) && (integer_to_ulong_p (x)))
{
ht_record_t * record;
if (external_strings == 0)
external_strings = (make_hash_table ());
record = (ht_lookup (external_strings, (integer_to_ulong (x))));
PRIMITIVE_RETURN (BOOLEAN_TO_OBJECT (record != 0));
}
else
PRIMITIVE_RETURN (SHARP_F);
}
}
DEFINE_PRIMITIVE ("DEALLOCATE-EXTERNAL-STRING", Prim_dealloc_external_string, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
{
unsigned long n = (arg_ulong_integer (1));
ht_record_t * record;
if (external_strings == 0)
external_strings = (make_hash_table ());
record = (ht_delete (external_strings, n));
if (record == 0)
error_wrong_type_arg (1);
free (record);
PRIMITIVE_RETURN (UNSPECIFIC);
}
}
DEFINE_PRIMITIVE ("EXTENDED-STRING-LENGTH", Prim_extended_string_length, 1, 1, 0)
{
PRIMITIVE_HEADER (1);
{
unsigned long len;
arg_extended_string (1, (&len));
PRIMITIVE_RETURN (ulong_to_integer (len));
}
}
PTR
DEFUN (arg_extended_string, (n), unsigned int n AND unsigned long * lp)
{
SCHEME_OBJECT object = (ARG_REF (n));
if (STRING_P (object))
{
if (lp != 0)
(*lp) = (STRING_LENGTH (object));
return (STRING_LOC (object, 0));
}
else if ((INTEGER_P (object)) && (integer_to_ulong_p (object)))
{
ht_record_t * record;
if (external_strings == 0)
external_strings = (make_hash_table ());
record = (ht_lookup (external_strings, (integer_to_ulong (object))));
if (record == 0)
error_wrong_type_arg (n);
if (lp != 0)
(*lp) = (HT_RECORD_N_BYTES (record));
return (HT_RECORD_PTR (record));
}
else
{
error_wrong_type_arg (n);
return (0);
}
}
#define HT_MIN_EXPT 4
#define HT_MAX_EXPT 24
#define EXPT_TO_N(e) ((1 << (e)) - 1)
static hash_table_t *
DEFUN_VOID (make_hash_table)
{
unsigned long n = (EXPT_TO_N (HT_MIN_EXPT));
hash_table_t * table = (malloc (sizeof (hash_table_t)));
if (table == 0)
abort ();
(HT_N_RECORDS (table)) = 0;
(HT_N_BUCKETS (table)) = n;
(HT_BUCKETS (table)) = (malloc (n * (sizeof (ht_record_t *))));
if ((HT_BUCKETS (table)) == 0)
abort ();
zero_ht_buckets (table);
return (table);
}
static void
DEFUN (ht_resize, (table, new_n_buckets),
hash_table_t * table AND
unsigned long new_n_buckets)
{
ht_record_t ** new_buckets
= (malloc (new_n_buckets * (sizeof (ht_record_t *))));
if (new_buckets != 0)
{
ht_record_t * records = (ht_records_list (table));
(HT_BUCKETS (table)) = new_buckets;
(HT_N_BUCKETS (table)) = new_n_buckets;
(HT_N_RECORDS (table)) = 0;
zero_ht_buckets (table);
while (records != 0)
{
ht_record_t * next = (HT_RECORD_NEXT (records));
ht_insert (table, records);
records = next;
}
}
}
static void
DEFUN (zero_ht_buckets, (table), hash_table_t * table)
{
ht_record_t ** scan = (HT_BUCKETS (table));
ht_record_t ** end = (scan + (HT_N_BUCKETS (table)));
while (scan < end)
(*scan++) = 0;
}
static ht_record_t *
DEFUN (ht_records_list, (table), hash_table_t * table)
{
ht_record_t ** scan_buckets = (HT_BUCKETS (table));
ht_record_t ** end_buckets = (scan_buckets + (HT_N_BUCKETS (table)));
ht_record_t * result = 0;
while (scan_buckets < end_buckets)
{
ht_record_t * scan = (*scan_buckets);
while (scan != 0)
{
ht_record_t * next = (HT_RECORD_NEXT (scan));
(HT_RECORD_NEXT (scan)) = result;
result = scan;
scan = next;
}
(*scan_buckets++) = 0;
}
return (result);
}
static ht_record_t *
DEFUN (ht_lookup, (table, key),
hash_table_t * table AND
unsigned long key)
{
unsigned long index = (HT_BUCKET_INDEX (table, key));
ht_record_t * record = (HT_BUCKET_REF (table, index));
while (record != 0)
{
if ((HT_RECORD_KEY (record)) == key)
return (record);
record = (HT_RECORD_NEXT (record));
}
return (0);
}
static unsigned long
DEFUN (ht_insert, (table, record),
hash_table_t * table AND
ht_record_t * record)
{
unsigned long index = (HT_BUCKET_INDEX (table, (HT_RECORD_KEY (record))));
ht_record_t * scan = (HT_BUCKET_REF (table, index));
(HT_RECORD_NEXT (record)) = 0;
if (scan == 0)
(HT_BUCKET_REF (table, index)) = record;
else
{
while ((HT_RECORD_NEXT (scan)) != 0)
scan = (HT_RECORD_NEXT (scan));
(HT_RECORD_NEXT (scan)) = record;
}
(HT_N_RECORDS (table)) += 1;
if (((HT_N_RECORDS (table)) >= (HT_N_BUCKETS (table)))
&& ((HT_N_BUCKETS (table)) < (EXPT_TO_N (HT_MAX_EXPT))))
{
unsigned int e = HT_MIN_EXPT;
while (e <= HT_MAX_EXPT)
{
unsigned long n = (EXPT_TO_N (e));
if (n > (HT_N_BUCKETS (table)))
{
ht_resize (table, n);
break;
}
e += 1;
}
}
return (HT_RECORD_KEY (record));
}
static ht_record_t *
DEFUN (ht_delete, (table, key),
hash_table_t * table AND
unsigned long key)
{
unsigned long index = (HT_BUCKET_INDEX (table, key));
ht_record_t * scan = (HT_BUCKET_REF (table, index));
ht_record_t * prev = 0;
while (1)
{
if (scan == 0)
return (0);
if ((HT_RECORD_KEY (scan)) == key)
break;
prev = scan;
scan = (HT_RECORD_NEXT (scan));
}
if (prev == 0)
(HT_BUCKET_REF (table, index)) = (HT_RECORD_NEXT (scan));
else
(HT_RECORD_NEXT (prev)) = (HT_RECORD_NEXT (scan));
(HT_N_RECORDS (table)) -= 1;
if (((HT_N_RECORDS (table)) < (HT_SHRINK_POINT (table)))
&& ((HT_N_BUCKETS (table)) > (EXPT_TO_N (HT_MIN_EXPT))))
{
unsigned int e = HT_MAX_EXPT;
while (e >= HT_MIN_EXPT)
{
unsigned long n = (EXPT_TO_N (e));
if (n < (HT_N_BUCKETS (table)))
{
ht_resize (table, n);
break;
}
e -= 1;
}
}
return (scan);
}
syntax highlighted by Code2HTML, v. 0.9.1