mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
Partial fix for <https://bugs.gnu.org/33044>. Reported by Tom de Vries <tdevries@suse.de>. Fix several instances of the mistake of using 'scm_from_locale_*' for C strings that originally came from a C string literal. Change several uses of 'scm_from_latin1_*' as well, to promote the practice of writing code that works for arbitrary C string literals. Also add missing years to the copyright notices of changed files, based on the git history. * libguile/debug-malloc.c, libguile/deprecation.c, libguile/error.c, libguile/eval.c, libguile/expand.c, libguile/extensions.c, libguile/filesys.c, libguile/init.c, libguile/load.c, libguile/modules.c, libguile/pairs.c, libguile/posix.c, libguile/print.c, libguile/random.c, libguile/read.c, libguile/regex-posix.c, libguile/snarf.h, libguile/srfi-13.c, libguile/stacks.c, libguile/stime.c, libguile/strports.c, libguile/values.c: Use 'scm_from_utf8_*' where appropriate.
250 lines
6.3 KiB
C
250 lines
6.3 KiB
C
/* Copyright 2000-2002,2004,2006,2008-2009,2018-2019
|
|
Free Software Foundation, Inc.
|
|
|
|
This file is part of Guile.
|
|
|
|
Guile is free software: you can redistribute it and/or modify it
|
|
under the terms of the GNU Lesser General Public License as published
|
|
by the Free Software Foundation, either version 3 of the License, or
|
|
(at your option) any later version.
|
|
|
|
Guile 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 Lesser General Public
|
|
License for more details.
|
|
|
|
You should have received a copy of the GNU Lesser General Public
|
|
License along with Guile. If not, see
|
|
<https://www.gnu.org/licenses/>. */
|
|
|
|
#ifdef HAVE_CONFIG_H
|
|
# include <config.h>
|
|
#endif
|
|
|
|
#include <string.h>
|
|
#include <stdio.h>
|
|
|
|
#include "alist.h"
|
|
#include "gsubr.h"
|
|
#include "numbers.h"
|
|
#include "strings.h"
|
|
|
|
#include "debug-malloc.h"
|
|
|
|
|
|
/*
|
|
* The following code is a hack which I wrote quickly in order to
|
|
* solve a memory leak problem. Since I wanted to have the
|
|
* application running at close to normal speed, I prioritized speed
|
|
* over maintainability. /mdj
|
|
*/
|
|
|
|
typedef struct hash_entry {
|
|
const void *key;
|
|
const void *data;
|
|
} hash_entry_t;
|
|
|
|
#define N_SEEK 8
|
|
|
|
static int malloc_type_size = 31;
|
|
static hash_entry_t *malloc_type = 0;
|
|
static int malloc_object_size = 8191;
|
|
static hash_entry_t *malloc_object = 0;
|
|
|
|
#define TABLE(table) malloc_ ## table
|
|
#define SIZE(table) malloc_ ## table ## _size
|
|
#define HASH(table, key) \
|
|
&TABLE (table)[((unsigned long) key >> 4UL) * 2654435761UL % SIZE (table)]
|
|
|
|
#define CREATE_HASH_ENTRY_AT(entry, table, h, k, done) \
|
|
{ \
|
|
int i; \
|
|
do \
|
|
{ \
|
|
for (i = 0; i < N_SEEK; ++i) \
|
|
if (h[i].key == 0) \
|
|
goto done; \
|
|
grow (&TABLE (table), &SIZE (table)); \
|
|
h = HASH (table, k); \
|
|
} \
|
|
while (1); \
|
|
done: \
|
|
(entry) = &h[i]; \
|
|
}
|
|
|
|
#define CREATE_HASH_ENTRY(table, k, d, done) \
|
|
do \
|
|
{ \
|
|
hash_entry_t *h = HASH (table, k); \
|
|
hash_entry_t *entry; \
|
|
CREATE_HASH_ENTRY_AT (entry, table, h, k, done); \
|
|
entry->key = (k); \
|
|
entry->data = (d); \
|
|
} \
|
|
while (0)
|
|
|
|
#define GET_CREATE_HASH_ENTRY(entry, table, k, done) \
|
|
do \
|
|
{ \
|
|
hash_entry_t *h = HASH (table, k); \
|
|
int i; \
|
|
for (i = 0; i < N_SEEK; ++i) \
|
|
if (h[i].key == (void *) (k)) \
|
|
goto done; \
|
|
CREATE_HASH_ENTRY_AT (entry, table, h, k, gche ## done); \
|
|
entry->key = (k); \
|
|
entry->data = 0; \
|
|
break; \
|
|
done: \
|
|
(entry) = &h[i]; \
|
|
} \
|
|
while (0)
|
|
|
|
static void
|
|
grow (hash_entry_t **table, int *size)
|
|
{
|
|
hash_entry_t *oldtable = *table;
|
|
int oldsize = *size + N_SEEK;
|
|
hash_entry_t *TABLE (new) = 0;
|
|
int SIZE (new);
|
|
int i, j;
|
|
SIZE (new) = 2 * (oldsize - N_SEEK + 1) - 1;
|
|
again:
|
|
TABLE (new) = realloc (TABLE (new),
|
|
sizeof (hash_entry_t) * (SIZE (new) + N_SEEK));
|
|
memset (TABLE (new), 0, sizeof (hash_entry_t) * (SIZE (new) + N_SEEK));
|
|
for (i = 0; i < oldsize; ++i)
|
|
if (oldtable[i].key)
|
|
{
|
|
hash_entry_t *h = HASH (new, oldtable[i].key);
|
|
for (j = 0; j < N_SEEK; ++j)
|
|
if (h[j].key == 0)
|
|
{
|
|
h[j] = oldtable[i];
|
|
goto next;
|
|
}
|
|
SIZE (new) *= 2;
|
|
goto again;
|
|
next:
|
|
;
|
|
}
|
|
if (table == &malloc_type)
|
|
{
|
|
/* relocate malloc_object entries */
|
|
for (i = 0; i < oldsize; ++i)
|
|
if (oldtable[i].key)
|
|
{
|
|
hash_entry_t *h = HASH (new, oldtable[i].key);
|
|
while (h->key != oldtable[i].key)
|
|
++h;
|
|
oldtable[i].data = h;
|
|
}
|
|
for (i = 0; i < malloc_object_size + N_SEEK; ++i)
|
|
if (malloc_object[i].key)
|
|
malloc_object[i].data
|
|
= ((hash_entry_t *) malloc_object[i].data)->data;
|
|
}
|
|
free (*table);
|
|
*table = TABLE (new);
|
|
*size = SIZE (new);
|
|
}
|
|
|
|
void
|
|
scm_malloc_register (void *obj, const char *what)
|
|
{
|
|
hash_entry_t *type;
|
|
GET_CREATE_HASH_ENTRY (type, type, what, l1);
|
|
type->data = (void *) ((int) type->data + 1);
|
|
CREATE_HASH_ENTRY (object, obj, type, l2);
|
|
}
|
|
|
|
void
|
|
scm_malloc_unregister (void *obj)
|
|
{
|
|
hash_entry_t *object, *type;
|
|
GET_CREATE_HASH_ENTRY (object, object, obj, l1);
|
|
type = (hash_entry_t *) object->data;
|
|
if (type == 0)
|
|
{
|
|
fprintf (stderr,
|
|
"scm_gc_free called on object not allocated with scm_gc_malloc\n");
|
|
abort ();
|
|
}
|
|
type->data = (void *) ((int) type->data - 1);
|
|
object->key = 0;
|
|
}
|
|
|
|
void
|
|
scm_malloc_reregister (void *old, void *new, const char *newwhat)
|
|
{
|
|
hash_entry_t *object, *type;
|
|
|
|
if (old == NULL)
|
|
scm_malloc_register (new, newwhat);
|
|
else
|
|
{
|
|
GET_CREATE_HASH_ENTRY (object, object, old, l1);
|
|
type = (hash_entry_t *) object->data;
|
|
if (type == 0)
|
|
{
|
|
fprintf (stderr,
|
|
"scm_gc_realloc called on object not allocated "
|
|
"with scm_gc_malloc\n");
|
|
abort ();
|
|
}
|
|
if (strcmp ((char *) type->key, newwhat) != 0)
|
|
{
|
|
if (strcmp (newwhat, "vector-set-length!") != 0)
|
|
{
|
|
fprintf (stderr,
|
|
"scm_gc_realloc called with arg %s, was %s\n",
|
|
newwhat,
|
|
(char *) type->key);
|
|
abort ();
|
|
}
|
|
}
|
|
if (new != old)
|
|
{
|
|
object->key = 0;
|
|
CREATE_HASH_ENTRY (object, new, type, l2);
|
|
}
|
|
}
|
|
}
|
|
|
|
SCM_DEFINE (scm_malloc_stats, "malloc-stats", 0, 0, 0,
|
|
(),
|
|
"Return an alist ((@var{what} . @var{n}) ...) describing number\n"
|
|
"of malloced objects.\n"
|
|
"@var{what} is the second argument to @code{scm_gc_malloc},\n"
|
|
"@var{n} is the number of objects of that type currently\n"
|
|
"allocated.")
|
|
#define FUNC_NAME s_scm_malloc_stats
|
|
{
|
|
SCM res = SCM_EOL;
|
|
int i;
|
|
for (i = 0; i < malloc_type_size + N_SEEK; ++i)
|
|
if (malloc_type[i].key)
|
|
res = scm_acons (scm_from_utf8_string ((char *) malloc_type[i].key),
|
|
scm_from_int ((int) malloc_type[i].data),
|
|
res);
|
|
return res;
|
|
}
|
|
#undef FUNC_NAME
|
|
|
|
void
|
|
scm_debug_malloc_prehistory ()
|
|
{
|
|
malloc_type = malloc (sizeof (hash_entry_t)
|
|
* (malloc_type_size + N_SEEK));
|
|
memset (malloc_type, 0, sizeof (hash_entry_t) * (malloc_type_size + N_SEEK));
|
|
malloc_object = malloc (sizeof (hash_entry_t)
|
|
* (malloc_object_size + N_SEEK));
|
|
memset (malloc_object, 0, sizeof (hash_entry_t) * (malloc_object_size + N_SEEK));
|
|
}
|
|
|
|
void
|
|
scm_init_debug_malloc ()
|
|
{
|
|
#include "debug-malloc.x"
|
|
}
|
|
|