/* Recording what needs to be marked for gc. */
struct gcpro *gcprolist;
-
-static void
-XFLOAT_INIT (Lisp_Object f, double n)
-{
- XFLOAT (f)->u.data = n;
-}
-
\f
/************************************************************************
Malloc
return;
}
+/* Allocate pointerless memory. */
+
+void *
+xmalloc_atomic (size_t size)
+{
+ void *val = GC_MALLOC_ATOMIC (size);
+ if (! val && size)
+ memory_full (size);
+ return val;
+}
+
+void *
+xzalloc_atomic (size_t size)
+{
+ return xmalloc_atomic (size);
+}
+
+/* Allocate uncollectable memory. */
+
+void *
+xmalloc_uncollectable (size_t size)
+{
+ void *val = GC_MALLOC_UNCOLLECTABLE (size);
+ if (! val && size)
+ memory_full (size);
+ return val;
+}
+
+/* Allocate memory, but if memory is exhausted, return NULL instead of
+ signalling an error. */
+
+void *
+xmalloc_unsafe (size_t size)
+{
+ return GC_MALLOC (size);
+}
+
+/* Allocate pointerless memory, but if memory is exhausted, return
+ NULL instead of signalling an error. */
+
+void *
+xmalloc_atomic_unsafe (size_t size)
+{
+ return GC_MALLOC_ATOMIC (size);
+}
/* Other parts of Emacs pass large int values to allocator functions
expecting ptrdiff_t. This is portable in practice, but check it to
return xmalloc (nitems * item_size);
}
+/* Like xnmalloc for pointerless objects. */
+
+void *
+xnmalloc_atomic (ptrdiff_t nitems, ptrdiff_t item_size)
+{
+ eassert (0 <= nitems && 0 < item_size);
+ if (min (PTRDIFF_MAX, SIZE_MAX) / item_size < nitems)
+ memory_full (SIZE_MAX);
+ return xmalloc_atomic (nitems * item_size);
+}
/* Reallocate an array PA to make it of NITEMS items, each of size ITEM_SIZE.
Signal an error on memory exhaustion. */
ptrdiff_t size;
eassert (s);
size = strlen (s) + 1;
- return memcpy (xmalloc (size), s, size);
+ return memcpy (xmalloc_atomic (size), s, size);
}
/* Like above, but duplicates Lisp string to C string. */
xlispstrdup (Lisp_Object string)
{
ptrdiff_t size = SBYTES (string) + 1;
- return memcpy (xmalloc (size), SSDATA (string), size);
+ return memcpy (xmalloc_atomic (size), SSDATA (string), size);
}
/* Assign to *PTR a copy of STRING, freeing any storage *PTR formerly
if (putenv ((char *) string) != 0)
memory_full (0);
}
-
-/* Return a newly allocated memory block of SIZE bytes, remembering
- to free it when unwinding. */
-void *
-record_xmalloc (size_t size)
-{
- void *p = xmalloc (size);
- record_unwind_protect_ptr (xfree, p);
- return p;
-}
\f
/***********************************************************************
Interval Allocation
static struct Lisp_String *
allocate_string (void)
{
- return xmalloc (sizeof (struct Lisp_String));
+ struct Lisp_String *p;
+
+ p = xmalloc (sizeof *p);
+ SCM_NEWSMOB (p->self, lisp_string_tag, p);
+ return p;
}
Lisp_Object
make_float (double float_value)
{
- register Lisp_Object val;
- XSETFLOAT (val, xmalloc (sizeof (struct Lisp_Float)));
- XFLOAT_INIT (val, float_value);
- return val;
+ return scm_from_double (float_value);
}
-
\f
/***********************************************************************
Cons Allocation
doc: /* Create a new cons, give it CAR and CDR as components, and return it. */)
(Lisp_Object car, Lisp_Object cdr)
{
- register Lisp_Object val;
-
- XSETCONS (val, xmalloc (sizeof (struct Lisp_Cons)));
- XSETCAR (val, car);
- XSETCDR (val, cdr);
- return val;
+ return scm_cons (car, cdr);
}
/* Make a list of 1, 2, 3, 4 or 5 specified objects. */
static void
init_vectors (void)
{
- XSETVECTOR (zero_vector, xmalloc (header_size));
- XVECTOR (zero_vector)->header.size = 0;
+ struct Lisp_Vector *p = xmalloc (header_size);
+
+ SCM_NEWSMOB (p->header.self, lisp_vectorlike_tag, p);
+ p->header.size = 0;
+ XSETVECTOR (zero_vector, p);
}
/* Value is a pointer to a newly allocated Lisp_Vector structure
static struct Lisp_Vector *
allocate_vectorlike (ptrdiff_t len)
{
+ struct Lisp_Vector *p;
+
if (len == 0)
- return XVECTOR (zero_vector);
+ p = XVECTOR (zero_vector);
else
- return xmalloc (header_size + len * word_size);
+ {
+ p = xmalloc (header_size + len * word_size);
+ SCM_NEWSMOB (p->header.self, lisp_vectorlike_tag, p);
+ }
+
+ return p;
}
{
struct buffer *b = xmalloc (sizeof *b);
+ SCM_NEWSMOB (b->header.self, lisp_vectorlike_tag, b);
BUFFER_PVEC_INIT (b);
/* Put B on the chain of all buffers including killed ones. */
b->next = all_buffers;
Symbol Allocation
***********************************************************************/
-static void
-set_symbol_name (Lisp_Object sym, Lisp_Object name)
+void
+initialize_symbol (Lisp_Object val, Lisp_Object name)
{
- XSYMBOL (sym)->name = name;
+ sym_t p;
+
+ scm_module_define (symbol_module, val, scm_c_make_vector (5, SCM_BOOL_F));
+ p = XSYMBOL (val);
+ SET_SYMBOL_SELF (p, val);
+ scm_module_define (plist_module, val, Qnil);
+ SET_SYMBOL_REDIRECT (p, SYMBOL_PLAINVAL);
+ SET_SYMBOL_VAL (p, Qunbound);
+ scm_module_define (function_module, val, Qnil);
+ SET_SYMBOL_CONSTANT (p, 0);
+ SET_SYMBOL_DECLARED_SPECIAL (p, false);
}
DEFUN ("make-symbol", Fmake_symbol, Smake_symbol, 1, 1, 0,
(Lisp_Object name)
{
register Lisp_Object val;
- register struct Lisp_Symbol *p;
CHECK_STRING (name);
- XSETSYMBOL (val, xmalloc (sizeof (struct Lisp_Symbol)));
- p = XSYMBOL (val);
- set_symbol_name (val, name);
- set_symbol_plist (val, Qnil);
- p->redirect = SYMBOL_PLAINVAL;
- SET_SYMBOL_VAL (p, Qunbound);
- set_symbol_function (val, Qnil);
- set_symbol_next (val, NULL);
- p->gcmarkbit = false;
- p->interned = SYMBOL_UNINTERNED;
- p->constant = 0;
- p->declared_special = false;
- p->pinned = false;
+ val = scm_make_symbol (scm_from_utf8_stringn (SSDATA (name),
+ SBYTES (name)));
+ initialize_symbol (val, name);
return val;
}
allocate_misc (enum Lisp_Misc_Type type)
{
Lisp_Object val;
+ union Lisp_Misc *p;
- XSETMISC (val, xmalloc (sizeof (union Lisp_Misc)));
+ p = xmalloc (sizeof *p);
+ SCM_NEWSMOB (p->u_any.self, lisp_misc_tag, p);
+ XSETMISC (val, p);
XMISCANY (val)->type = type;
return val;
}
bool enough_free_memory = 0;
if (SPARE_MEMORY < nbytes)
{
- void *p = GC_MALLOC (SPARE_MEMORY);
+ void *p = xmalloc_atomic_unsafe (SPARE_MEMORY);
if (p)
{
xfree (p);
refill_memory_reserve (void)
{
if (spare_memory == NULL)
- spare_memory = GC_MALLOC (SPARE_MEMORY);
+ spare_memory = xmalloc_atomic_unsafe (SPARE_MEMORY);
if (spare_memory)
Vmemory_full = Qnil;
{
void *p;
- if (INTEGERP (obj))
+ if (SCM_IMP (obj))
return 1;
- p = (void *) XPNTR (obj);
+ p = (void *) SCM2PTR (obj);
if (p == &buffer_defaults || p == &buffer_local_symbols)
return 2;
void
init_alloc_once (void)
{
+ lisp_misc_tag = scm_make_smob_type ("elisp-misc", 0);
+ lisp_string_tag = scm_make_smob_type ("elisp-string", 0);
+ lisp_vectorlike_tag = scm_make_smob_type ("elisp-vectorlike", 0);
+
/* Used to do Vpurify_flag = Qt here, but Qt isn't set up yet! */
init_strings ();
void
syms_of_alloc (void)
{
+#include "alloc.x"
+
DEFVAR_INT ("gc-cons-threshold", gc_cons_threshold,
doc: /* Number of bytes of consing between garbage collections.
Garbage collection can happen automatically once this many bytes have been
The time is in seconds as a floating point value. */);
DEFVAR_INT ("gcs-done", gcs_done,
doc: /* Accumulated number of garbage collections done. */);
-
- defsubr (&Scons);
- defsubr (&Slist);
- defsubr (&Svector);
- defsubr (&Sbool_vector);
- defsubr (&Smake_byte_code);
- defsubr (&Smake_list);
- defsubr (&Smake_vector);
- defsubr (&Smake_string);
- defsubr (&Smake_bool_vector);
- defsubr (&Smake_symbol);
- defsubr (&Smake_marker);
- defsubr (&Spurecopy);
- defsubr (&Sgarbage_collect);
}
/* When compiled with GCC, GDB might say "No enum type named
enum CHARTAB_SIZE_BITS CHARTAB_SIZE_BITS;
enum CHAR_TABLE_STANDARD_SLOTS CHAR_TABLE_STANDARD_SLOTS;
enum char_bits char_bits;
- enum CHECK_LISP_OBJECT_TYPE CHECK_LISP_OBJECT_TYPE;
enum DEFAULT_HASH_SIZE DEFAULT_HASH_SIZE;
enum Lisp_Bits Lisp_Bits;
enum Lisp_Compiled Lisp_Compiled;
HCoop / bpt / emacs.git / blobdiff