mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-10 05:50:26 +02:00
New files: dump.c, dump.h.
This commit is contained in:
parent
00ffa0e7d6
commit
03416a991e
8 changed files with 1009 additions and 86 deletions
|
@ -1,3 +1,20 @@
|
|||
2001-02-02 Keisuke Nishida <kxn30@po.cwru.edu>
|
||||
|
||||
* dump.c, dump.h: New files.
|
||||
* Makefile.am: Added dump.c, dump.h, dump.x, dump.doc.
|
||||
* init.c: #include "libguile/dump.h".
|
||||
(scm_init_guile_1): Call scm_init_dump.
|
||||
* smob.h (scm_smob_descriptor): New slots: dump_mark,
|
||||
dump_dealloc, dump_store, undump_alloc, undump_restore,
|
||||
undump_init.
|
||||
* smob.c (scm_make_smob_type): Init the new slots.
|
||||
(scm_set_smob_dump, scm_set_smob_undump): New functions.
|
||||
* smob.h (scm_set_smob_dump, scm_set_smob_undump): Declared.
|
||||
|
||||
* keywords.c: #include "libguile/dump.h".
|
||||
(keyword_dealloc, keyword_alloc): New functions.
|
||||
(scm_init_keywords): Set smob_dump and smob_undump.
|
||||
|
||||
2001-02-01 Keisuke Nishida <kxn30@po.cwru.edu>
|
||||
|
||||
* vectors.c (scm_c_make_vector): New function.
|
||||
|
|
|
@ -38,56 +38,47 @@ guile_SOURCES = guile.c
|
|||
guile_LDADD = libguile.la ${THREAD_LIBS_LOCAL}
|
||||
guile_LDFLAGS = @DLPREOPEN@
|
||||
|
||||
libguile_la_SOURCES = \
|
||||
alist.c arbiters.c async.c backtrace.c boolean.c chars.c \
|
||||
continuations.c debug.c dynl.c dynwind.c environments.c eq.c error.c \
|
||||
eval.c evalext.c feature.c fluids.c fports.c gc.c gdbint.c gh_data.c \
|
||||
gh_eval.c gh_funcs.c gh_init.c gh_io.c gh_list.c gh_predicates.c \
|
||||
goops.c gsubr.c guardians.c hash.c hashtab.c hooks.c init.c ioext.c \
|
||||
iselect.c keywords.c lang.c list.c load.c macros.c mallocs.c \
|
||||
modules.c numbers.c objects.c objprop.c options.c pairs.c ports.c \
|
||||
print.c procprop.c procs.c random.c rdelim.c \
|
||||
read.c root.c scmsigs.c \
|
||||
script.c simpos.c smob.c sort.c srcprop.c stackchk.c stacks.c \
|
||||
stime.c strings.c strop.c strorder.c strports.c struct.c symbols.c \
|
||||
tag.c throw.c values.c variable.c vectors.c version.c vports.c weaks.c \
|
||||
gc_os_dep.c properties.c
|
||||
libguile_la_SOURCES = alist.c arbiters.c async.c backtrace.c boolean.c \
|
||||
chars.c continuations.c debug.c dump.c dynl.c dynwind.c \
|
||||
environments.c eq.c error.c eval.c evalext.c feature.c fluids.c fports.c \
|
||||
gc.c gc_os_dep.c gdbint.c gh_data.c gh_eval.c gh_funcs.c gh_init.c \
|
||||
gh_io.c gh_list.c gh_predicates.c goops.c gsubr.c guardians.c hash.c \
|
||||
hashtab.c hooks.c init.c ioext.c iselect.c keywords.c lang.c list.c \
|
||||
load.c macros.c mallocs.c modules.c numbers.c objects.c objprop.c \
|
||||
options.c pairs.c ports.c print.c procprop.c procs.c properties.c \
|
||||
random.c rdelim.c read.c root.c scmsigs.c script.c simpos.c smob.c \
|
||||
sort.c srcprop.c stackchk.c stacks.c stime.c strings.c strop.c \
|
||||
strorder.c strports.c struct.c symbols.c tag.c throw.c values.c \
|
||||
variable.c vectors.c version.c vports.c weaks.c
|
||||
|
||||
DOT_X_FILES = \
|
||||
alist.x arbiters.x \
|
||||
async.x backtrace.x boolean.x chars.x continuations.x debug.x \
|
||||
dynl.x dynwind.x environments.x eq.x error.x eval.x evalext.x \
|
||||
feature.x \
|
||||
fluids.x fports.x gc.x goops.x gsubr.x guardians.x hash.x hashtab.x \
|
||||
hooks.x init.x ioext.x iselect.x keywords.x lang.x list.x load.x \
|
||||
macros.x mallocs.x modules.x net_db.x numbers.x objects.x \
|
||||
objprop.x options.x pairs.x ports.x posix.x print.x procprop.x \
|
||||
procs.x random.x rdelim.x read.x root.x scmsigs.x \
|
||||
script.x simpos.x smob.x socket.x sort.x srcprop.x stackchk.x \
|
||||
stacks.x stime.x strings.x strop.x strorder.x strports.x struct.x \
|
||||
symbols.x tag.x throw.x values.x variable.x vectors.x \
|
||||
version.x vports.x weaks.x properties.x
|
||||
DOT_X_FILES = alist.x arbiters.x async.x backtrace.x boolean.x chars.x \
|
||||
continuations.x debug.x dump.x dynl.x dynwind.x environments.x eq.x \
|
||||
error.x eval.x evalext.x feature.x fluids.x fports.x gc.x goops.x \
|
||||
gsubr.x guardians.x hash.x hashtab.x hooks.x init.x ioext.x iselect.x \
|
||||
keywords.x lang.x list.x load.x macros.x mallocs.x modules.x net_db.x \
|
||||
numbers.x objects.x objprop.x options.x pairs.x ports.x posix.x print.x \
|
||||
procprop.x procs.x properties.x random.x rdelim.x read.x root.x \
|
||||
scmsigs.x script.x simpos.x smob.x socket.x sort.x srcprop.x \
|
||||
stackchk.x stacks.x stime.x strings.x strop.x strorder.x strports.x \
|
||||
struct.x symbols.x tag.x throw.x values.x variable.x vectors.x \
|
||||
version.x vports.x weaks.x
|
||||
|
||||
EXTRA_DOT_X_FILES = debug-malloc.x filesys.x net_db.x posix.x ramap.x \
|
||||
regex-posix.x socket.x threads.x unif.x
|
||||
|
||||
DOT_DOC_FILES = \
|
||||
alist.doc arbiters.doc async.doc backtrace.doc boolean.doc \
|
||||
chars.doc continuations.doc debug.doc dynl.doc dynwind.doc \
|
||||
environments.doc eq.doc \
|
||||
error.doc eval.doc evalext.doc feature.doc fluids.doc fports.doc \
|
||||
gc.doc goops.doc gsubr.doc guardians.doc hash.doc hashtab.doc \
|
||||
hooks.doc init.doc \
|
||||
ioext.doc iselect.doc keywords.doc lang.doc list.doc load.doc \
|
||||
macros.doc mallocs.doc modules.doc net_db.doc numbers.doc objects.doc \
|
||||
objprop.doc options.doc pairs.doc ports.doc posix.doc print.doc \
|
||||
procprop.doc procs.doc random.doc rdelim.doc \
|
||||
read.doc root.doc scmsigs.doc \
|
||||
script.doc simpos.doc smob.doc socket.doc sort.doc srcprop.doc \
|
||||
stackchk.doc stacks.doc stime.doc strings.doc strop.doc strorder.doc \
|
||||
strports.doc struct.doc symbols.doc tag.doc throw.doc values.doc \
|
||||
variable.doc vectors.doc version.doc vports.doc weaks.doc \
|
||||
properties.doc
|
||||
DOT_DOC_FILES = alist.doc arbiters.doc async.doc backtrace.doc \
|
||||
boolean.doc chars.doc continuations.doc debug.doc dump.doc dynl.doc \
|
||||
dynwind.doc environments.doc eq.doc error.doc eval.doc evalext.doc \
|
||||
feature.doc fluids.doc fports.doc gc.doc goops.doc gsubr.doc \
|
||||
guardians.doc hash.doc hashtab.doc hooks.doc init.doc ioext.doc \
|
||||
iselect.doc keywords.doc lang.doc list.doc load.doc macros.doc \
|
||||
mallocs.doc modules.doc net_db.doc numbers.doc objects.doc objprop.doc \
|
||||
options.doc pairs.doc ports.doc posix.doc print.doc procprop.doc \
|
||||
procs.doc properties.doc random.doc rdelim.doc read.doc root.doc \
|
||||
scmsigs.doc script.doc simpos.doc smob.doc socket.doc sort.doc \
|
||||
srcprop.doc stackchk.doc stacks.doc stime.doc strings.doc strop.doc \
|
||||
strorder.doc strports.doc struct.doc symbols.doc tag.doc throw.doc \
|
||||
values.doc variable.doc vectors.doc version.doc vports.doc weaks.doc
|
||||
|
||||
EXTRA_DOT_DOC_FILES = @EXTRA_DOT_DOC_FILES@
|
||||
|
||||
|
@ -120,23 +111,18 @@ pkginclude_HEADERS = gh.h
|
|||
|
||||
# These are headers visible as <libguile/mumble.h>.
|
||||
modincludedir = $(includedir)/libguile
|
||||
modinclude_HEADERS = \
|
||||
__scm.h alist.h arbiters.h async.h backtrace.h boolean.h chars.h \
|
||||
continuations.h debug.h dynl.h dynwind.h environments.h eq.h \
|
||||
error.h eval.h \
|
||||
evalext.h feature.h filesys.h fports.h gc.h gdb_interface.h \
|
||||
gdbint.h goops.h gsubr.h guardians.h hash.h hashtab.h hooks.h init.h \
|
||||
ioext.h keywords.h lang.h list.h load.h macros.h mallocs.h \
|
||||
modules.h net_db.h numbers.h objects.h objprop.h options.h pairs.h \
|
||||
ports.h posix.h regex-posix.h print.h procprop.h procs.h random.h \
|
||||
ramap.h rdelim.h \
|
||||
read.h root.h scmsigs.h validate.h script.h simpos.h \
|
||||
smob.h socket.h sort.h srcprop.h stackchk.h stacks.h stime.h \
|
||||
strings.h strop.h strorder.h strports.h struct.h symbols.h tag.h \
|
||||
tags.h throw.h unif.h values.h variable.h vectors.h version.h \
|
||||
vports.h \
|
||||
weaks.h snarf.h threads.h coop-defs.h fluids.h iselect.h \
|
||||
debug-malloc.h properties.h
|
||||
modinclude_HEADERS = __scm.h alist.h arbiters.h async.h backtrace.h boolean.h \
|
||||
chars.h continuations.h coop-defs.h debug.h debug-malloc.h dump.h \
|
||||
dynl.h dynwind.h environments.h eq.h error.h eval.h evalext.h \
|
||||
feature.h filesys.h fluids.h fports.h gc.h gdb_interface.h gdbint.h \
|
||||
goops.h gsubr.h guardians.h hash.h hashtab.h hooks.h init.h ioext.h \
|
||||
iselect.h keywords.h lang.h list.h load.h macros.h mallocs.h modules.h \
|
||||
net_db.h numbers.h objects.h objprop.h options.h pairs.h ports.h posix.h \
|
||||
regex-posix.h print.h procprop.h procs.h properties.h random.h ramap.h \
|
||||
rdelim.h read.h root.h scmsigs.h validate.h script.h simpos.h smob.h \
|
||||
snarf.h socket.h sort.h srcprop.h stackchk.h stacks.h stime.h strings.h \
|
||||
strop.h strorder.h strports.h struct.h symbols.h tag.h tags.h threads.h \
|
||||
throw.h unif.h values.h variable.h vectors.h version.h vports.h weaks.h
|
||||
|
||||
## This file is generated at configure time. That is why it is DATA
|
||||
## and not a header -- headers are included in the distribution.
|
||||
|
|
778
libguile/dump.c
Normal file
778
libguile/dump.c
Normal file
|
@ -0,0 +1,778 @@
|
|||
/* Copyright (C) 2001 Free Software Foundation, Inc.
|
||||
*
|
||||
* 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, 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 software; see the file COPYING. If not, write to
|
||||
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||
* Boston, MA 02111-1307 USA
|
||||
*
|
||||
* As a special exception, the Free Software Foundation gives permission
|
||||
* for additional uses of the text contained in its release of GUILE.
|
||||
*
|
||||
* The exception is that, if you link the GUILE library with other files
|
||||
* to produce an executable, this does not by itself cause the
|
||||
* resulting executable to be covered by the GNU General Public License.
|
||||
* Your use of that executable is in no way restricted on account of
|
||||
* linking the GUILE library code into it.
|
||||
*
|
||||
* This exception does not however invalidate any other reasons why
|
||||
* the executable file might be covered by the GNU General Public License.
|
||||
*
|
||||
* This exception applies only to the code released by the
|
||||
* Free Software Foundation under the name GUILE. If you copy
|
||||
* code from other Free Software Foundation releases into a copy of
|
||||
* GUILE, as the General Public License permits, the exception does
|
||||
* not apply to the code that you add in this way. To avoid misleading
|
||||
* anyone as to the status of such modified files, you must delete
|
||||
* this exception notice from them.
|
||||
*
|
||||
* If you write modifications of your own for GUILE, it is your choice
|
||||
* whether to permit this exception to apply to your modifications.
|
||||
* If you do not wish that, delete this exception notice. */
|
||||
|
||||
|
||||
|
||||
#include <string.h>
|
||||
#include <unistd.h>
|
||||
#include <sys/mman.h>
|
||||
#include <sys/stat.h>
|
||||
#include <sys/types.h>
|
||||
|
||||
#include "libguile/_scm.h"
|
||||
#include "libguile/tags.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/alist.h"
|
||||
#include "libguile/smob.h"
|
||||
#include "libguile/ports.h"
|
||||
#include "libguile/fports.h"
|
||||
#include "libguile/strings.h"
|
||||
#include "libguile/hashtab.h"
|
||||
#include "libguile/vectors.h"
|
||||
#include "libguile/validate.h"
|
||||
#include "libguile/dump.h"
|
||||
|
||||
#define SCM_DUMP_COOKIE "\x7fGBF-0.0"
|
||||
|
||||
#define SCM_DUMP_INITIAL_HASH_SIZE 511
|
||||
#define SCM_DUMP_INITIAL_IMAGE_SIZE 4096
|
||||
|
||||
#define SCM_DUMP_INDEX_TO_WORD(x) ((scm_bits_t) ((x) << 3))
|
||||
#define SCM_DUMP_WORD_TO_INDEX(x) ((long) ((x) >> 3))
|
||||
|
||||
struct scm_dump_header {
|
||||
scm_bits_t cookie; /* cookie string */
|
||||
scm_bits_t version; /* version string */
|
||||
scm_bits_t nmeta; /* the number of meta data */
|
||||
scm_bits_t init; /* initial object indicator */
|
||||
};
|
||||
|
||||
struct scm_dump_meta {
|
||||
scm_bits_t tc; /* the type of objects */
|
||||
scm_bits_t nobjs; /* the number of objects */
|
||||
};
|
||||
|
||||
|
||||
/*
|
||||
* Dump state
|
||||
*/
|
||||
|
||||
static scm_bits_t scm_tc16_dstate;
|
||||
|
||||
struct scm_dstate {
|
||||
int mmapped;
|
||||
scm_sizet image_size;
|
||||
int image_index;
|
||||
char *image_base; /* memory image */
|
||||
SCM table; /* object table */
|
||||
};
|
||||
|
||||
#define SCM_DSTATE_DATA(d) ((struct scm_dstate *) SCM_SMOB_DATA (d))
|
||||
|
||||
#define SCM_DSTATE_TABLE(d) (SCM_DSTATE_DATA (d)->table)
|
||||
#define SCM_DSTATE_TABLE_LENGTH(d) SCM_VECTOR_LENGTH (SCM_DSTATE_TABLE (d))
|
||||
#define SCM_DSTATE_TABLE_BASE(d) SCM_VELTS (SCM_DSTATE_TABLE (d))
|
||||
|
||||
static SCM
|
||||
make_dstate ()
|
||||
#define FUNC_NAME "make_dstate"
|
||||
{
|
||||
struct scm_dstate *p = SCM_MUST_MALLOC (sizeof (struct scm_dstate));
|
||||
p->mmapped = 0;
|
||||
p->image_size = SCM_DUMP_INITIAL_IMAGE_SIZE;
|
||||
p->image_index = 0;
|
||||
p->image_base = SCM_MUST_MALLOC (p->image_size);
|
||||
p->table = SCM_BOOL_F;
|
||||
SCM_RETURN_NEWSMOB (scm_tc16_dstate, p);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
static SCM
|
||||
make_dstate_by_mmap (int fd)
|
||||
#define FUNC_NAME "make_dstate_by_mmap"
|
||||
{
|
||||
int ret;
|
||||
char *addr;
|
||||
struct stat st;
|
||||
struct scm_dstate *p = SCM_MUST_MALLOC (sizeof (struct scm_dstate));
|
||||
|
||||
SCM_SYSCALL (ret = fstat (fd, &st));
|
||||
if (ret < 0)
|
||||
SCM_SYSERROR;
|
||||
|
||||
SCM_SYSCALL (addr = mmap (0, st.st_size, PROT_READ, MAP_SHARED, fd, 0));
|
||||
if (addr == MAP_FAILED)
|
||||
SCM_SYSERROR;
|
||||
|
||||
p->mmapped = 1;
|
||||
p->image_size = st.st_size;
|
||||
p->image_index = 0;
|
||||
p->image_base = addr;
|
||||
p->table = SCM_BOOL_F;
|
||||
SCM_RETURN_NEWSMOB (scm_tc16_dstate, p);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
static SCM
|
||||
dstate_mark (SCM obj)
|
||||
{
|
||||
return SCM_DSTATE_TABLE (obj);
|
||||
}
|
||||
|
||||
static scm_sizet
|
||||
dstate_free (SCM obj)
|
||||
#define FUNC_NAME "dstate_free"
|
||||
{
|
||||
int size = sizeof (struct scm_dstate);
|
||||
struct scm_dstate *p = SCM_DSTATE_DATA (obj);
|
||||
if (p->mmapped)
|
||||
{
|
||||
int rv;
|
||||
SCM_SYSCALL (rv = munmap (p->image_base, p->image_size));
|
||||
if (rv < 0)
|
||||
SCM_SYSERROR;
|
||||
}
|
||||
else
|
||||
{
|
||||
size += p->image_size;
|
||||
if (p->image_base)
|
||||
scm_must_free (p->image_base);
|
||||
}
|
||||
scm_must_free (p);
|
||||
return size;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
static void
|
||||
dstate_extend (struct scm_dstate *p)
|
||||
{
|
||||
scm_sizet old_size = p->image_size;
|
||||
p->image_size *= 2;
|
||||
p->image_base = scm_must_realloc (p->image_base,
|
||||
old_size,
|
||||
p->image_size,
|
||||
"dstate_extend");
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
* Object indicator
|
||||
*/
|
||||
|
||||
static scm_bits_t
|
||||
scm_object_indicator (SCM obj, SCM dstate)
|
||||
{
|
||||
if (SCM_IMP (obj))
|
||||
return SCM_UNPACK (obj);
|
||||
else
|
||||
{
|
||||
int i;
|
||||
int len = SCM_DSTATE_TABLE_LENGTH (dstate);
|
||||
SCM *base = SCM_DSTATE_TABLE_BASE (dstate);
|
||||
for (i = 0; i < len; i++)
|
||||
if (SCM_EQ_P (obj, base[i]))
|
||||
return SCM_DUMP_INDEX_TO_WORD (i);
|
||||
}
|
||||
scm_misc_error ("scm_object_indicator",
|
||||
"Non-marked object: ~A", SCM_LIST1 (obj));
|
||||
return 0;
|
||||
}
|
||||
|
||||
static SCM
|
||||
scm_indicator_object (scm_bits_t word, SCM dstate)
|
||||
{
|
||||
if (SCM_IMP (SCM_PACK (word)))
|
||||
return SCM_PACK (word);
|
||||
else
|
||||
return SCM_DSTATE_TABLE_BASE (dstate)[SCM_DUMP_WORD_TO_INDEX (word)];
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
* Dump interface
|
||||
*/
|
||||
|
||||
static void
|
||||
scm_store_pad (SCM dstate)
|
||||
{
|
||||
struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
|
||||
while (p->image_index + sizeof (scm_bits_t) >= p->image_size)
|
||||
dstate_extend (p);
|
||||
while (p->image_index % sizeof (scm_bits_t) != 0)
|
||||
p->image_base[p->image_index++] = '\0';
|
||||
}
|
||||
|
||||
static void
|
||||
scm_store_chars (const char *addr, scm_sizet size, SCM dstate)
|
||||
{
|
||||
struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
|
||||
while (p->image_index + size >= p->image_size)
|
||||
dstate_extend (p);
|
||||
memcpy (p->image_base + p->image_index, addr, size);
|
||||
memcpy (p->image_base + p->image_index + size, "\0", 1);
|
||||
p->image_index += size + 1;
|
||||
}
|
||||
|
||||
void
|
||||
scm_store_string (const char *addr, scm_sizet size, SCM dstate)
|
||||
{
|
||||
scm_store_chars (addr, size, dstate);
|
||||
scm_store_pad (dstate);
|
||||
}
|
||||
|
||||
void
|
||||
scm_store_bytes (const char *addr, scm_sizet size, SCM dstate)
|
||||
{
|
||||
struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
|
||||
while (p->image_index + size >= p->image_size)
|
||||
dstate_extend (p);
|
||||
memcpy (p->image_base + p->image_index, addr, size);
|
||||
p->image_index += size;
|
||||
scm_store_pad (dstate);
|
||||
}
|
||||
|
||||
void
|
||||
scm_store_word (const scm_bits_t word, SCM dstate)
|
||||
{
|
||||
scm_store_bytes ((const char *) &word, sizeof (scm_bits_t), dstate);
|
||||
}
|
||||
|
||||
void
|
||||
scm_store_object (SCM obj, SCM dstate)
|
||||
{
|
||||
scm_store_word (scm_object_indicator (obj, dstate), dstate);
|
||||
}
|
||||
|
||||
static void
|
||||
scm_restore_pad (SCM dstate)
|
||||
{
|
||||
struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
|
||||
while (p->image_index % sizeof (scm_bits_t) != 0)
|
||||
p->image_index++;
|
||||
}
|
||||
|
||||
static const char *
|
||||
scm_restore_chars (SCM dstate, int *lenp)
|
||||
{
|
||||
struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
|
||||
const char *addr = p->image_base + p->image_index;
|
||||
*lenp = strlen (addr);
|
||||
p->image_index += *lenp + 1;
|
||||
return addr;
|
||||
}
|
||||
|
||||
const char *
|
||||
scm_restore_string (SCM dstate, int *lenp)
|
||||
{
|
||||
const char *addr = scm_restore_chars (dstate, lenp);
|
||||
scm_restore_pad (dstate);
|
||||
return addr;
|
||||
}
|
||||
|
||||
const char *
|
||||
scm_restore_bytes (SCM dstate, scm_sizet size)
|
||||
{
|
||||
struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
|
||||
const char *addr = p->image_base + p->image_index;
|
||||
p->image_index += size;
|
||||
scm_restore_pad (dstate);
|
||||
return addr;
|
||||
}
|
||||
|
||||
scm_bits_t
|
||||
scm_restore_word (SCM dstate)
|
||||
{
|
||||
struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
|
||||
scm_bits_t word = *(scm_bits_t *) (p->image_base + p->image_index);
|
||||
p->image_index += sizeof (scm_bits_t);
|
||||
return word;
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_restore_object (SCM dstate)
|
||||
{
|
||||
return scm_indicator_object (scm_restore_word (dstate), dstate);
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
* Dump routine
|
||||
*/
|
||||
|
||||
void
|
||||
scm_dump_mark (SCM obj, SCM dstate)
|
||||
{
|
||||
SCM table = SCM_DSTATE_TABLE (dstate);
|
||||
|
||||
loop:
|
||||
/* Nothing with immediates */
|
||||
if (SCM_IMP (obj))
|
||||
return;
|
||||
|
||||
/* Return if already marked */
|
||||
if (!SCM_FALSEP (scm_hashq_ref (table, obj, SCM_BOOL_F)))
|
||||
return;
|
||||
|
||||
if (SCM_SLOPPY_CONSP (obj))
|
||||
{
|
||||
scm_hashq_set_x (table, obj, SCM_MAKINUM (scm_tc3_cons));
|
||||
scm_dump_mark (SCM_CAR (obj), dstate);
|
||||
obj = SCM_CDR (obj);
|
||||
goto loop;
|
||||
}
|
||||
|
||||
switch (SCM_TYP7 (obj))
|
||||
{
|
||||
case scm_tc7_symbol:
|
||||
scm_hashq_set_x (table, obj, SCM_MAKINUM (scm_tc7_symbol));
|
||||
return;
|
||||
case scm_tc7_substring:
|
||||
case scm_tc7_string:
|
||||
scm_hashq_set_x (table, obj, SCM_MAKINUM (scm_tc7_string));
|
||||
return;
|
||||
case scm_tc7_vector:
|
||||
{
|
||||
int i;
|
||||
int len = SCM_VECTOR_LENGTH (obj);
|
||||
SCM *base = SCM_VELTS (obj);
|
||||
scm_hashq_set_x (table, obj, SCM_MAKINUM (scm_tc7_vector));
|
||||
for (i = 0; i < len; i++)
|
||||
scm_dump_mark (base[i], dstate);
|
||||
return;
|
||||
}
|
||||
case scm_tc7_smob:
|
||||
{
|
||||
SCM (*mark) () = SCM_SMOB_DESCRIPTOR (obj).dump_mark;
|
||||
void (*dealloc) () = SCM_SMOB_DESCRIPTOR (obj).dump_dealloc;
|
||||
void (*store) () = SCM_SMOB_DESCRIPTOR (obj).dump_store;
|
||||
|
||||
if (!(mark || dealloc || store))
|
||||
break;
|
||||
|
||||
scm_hashq_set_x (table, obj, SCM_MAKINUM (SCM_CELL_TYPE (obj)));
|
||||
if (mark)
|
||||
{
|
||||
obj = mark (obj, dstate);
|
||||
goto loop;
|
||||
}
|
||||
return;
|
||||
}
|
||||
}
|
||||
scm_misc_error ("scm_dump_mark", "Cannot dump: ~A", SCM_LIST1 (obj));
|
||||
}
|
||||
|
||||
static void
|
||||
scm_dump_dealloc (scm_bits_t tc, int nobjs, SCM *table, SCM dstate)
|
||||
{
|
||||
switch (SCM_ITAG7 (SCM_PACK (tc)))
|
||||
{
|
||||
case scm_tc7_symbol:
|
||||
{
|
||||
int i;
|
||||
for (i = 0; i < nobjs; i++)
|
||||
{
|
||||
SCM obj = table[i];
|
||||
scm_store_chars (SCM_SYMBOL_CHARS (obj),
|
||||
SCM_SYMBOL_LENGTH (obj),
|
||||
dstate);
|
||||
}
|
||||
scm_store_pad (dstate);
|
||||
return;
|
||||
}
|
||||
case scm_tc7_string:
|
||||
{
|
||||
int i;
|
||||
for (i = 0; i < nobjs; i++)
|
||||
{
|
||||
SCM obj = table[i];
|
||||
scm_store_chars (SCM_STRING_CHARS (obj),
|
||||
SCM_STRING_LENGTH (obj),
|
||||
dstate);
|
||||
}
|
||||
scm_store_pad (dstate);
|
||||
return;
|
||||
}
|
||||
case scm_tc7_vector:
|
||||
{
|
||||
int i;
|
||||
for (i = 0; i < nobjs; i++)
|
||||
scm_store_word (SCM_VECTOR_LENGTH (table[i]), dstate);
|
||||
return;
|
||||
}
|
||||
case scm_tc7_smob:
|
||||
{
|
||||
int i;
|
||||
void (*dealloc) () = scm_smobs[SCM_TC2SMOBNUM(tc)].dump_dealloc;
|
||||
if (dealloc)
|
||||
for (i = 0; i < nobjs; i++)
|
||||
dealloc (table[i], dstate);
|
||||
return;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
static void
|
||||
scm_dump_store (scm_bits_t tc, int nobjs, SCM *table, SCM dstate)
|
||||
{
|
||||
if (SCM_ITAG3 (SCM_PACK (tc)) == scm_tc3_cons)
|
||||
{
|
||||
int i;
|
||||
for (i = 0; i < nobjs; i++)
|
||||
{
|
||||
SCM obj = table[i];
|
||||
scm_store_object (SCM_CAR (obj), dstate);
|
||||
scm_store_object (SCM_CDR (obj), dstate);
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
switch (SCM_ITAG7 (SCM_PACK (tc)))
|
||||
{
|
||||
case scm_tc7_vector:
|
||||
{
|
||||
int i, j;
|
||||
for (i = 0; i < nobjs; i++)
|
||||
{
|
||||
SCM obj = table[i];
|
||||
int len = SCM_VECTOR_LENGTH (obj);
|
||||
SCM *base = SCM_VELTS (obj);
|
||||
for (j = 0; j < len; j++)
|
||||
scm_store_object (base[j], dstate);
|
||||
}
|
||||
return;
|
||||
}
|
||||
case scm_tc7_smob:
|
||||
{
|
||||
int i;
|
||||
void (*store) () = scm_smobs[SCM_TC2SMOBNUM(tc)].dump_store;
|
||||
if (store)
|
||||
for (i = 0; i < nobjs; i++)
|
||||
store (table[i], dstate);
|
||||
return;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
static void
|
||||
scm_undump_alloc (scm_bits_t tc, int nobjs, SCM *table, SCM dstate)
|
||||
{
|
||||
if (SCM_ITAG3 (SCM_PACK (tc)) == scm_tc3_cons)
|
||||
{
|
||||
int i;
|
||||
for (i = 0; i < nobjs; i++)
|
||||
SCM_NEWCELL (table[i]);
|
||||
return;
|
||||
}
|
||||
|
||||
switch (SCM_ITAG7 (SCM_PACK (tc)))
|
||||
{
|
||||
case scm_tc7_symbol:
|
||||
{
|
||||
int i;
|
||||
for (i = 0; i < nobjs; i++)
|
||||
{
|
||||
int len;
|
||||
const char *mem = scm_restore_chars (dstate, &len);
|
||||
table[i] = scm_mem2symbol (mem, len);
|
||||
}
|
||||
scm_restore_pad (dstate);
|
||||
return;
|
||||
}
|
||||
case scm_tc7_string:
|
||||
{
|
||||
int i;
|
||||
for (i = 0; i < nobjs; i++)
|
||||
{
|
||||
int len;
|
||||
const char *mem = scm_restore_chars (dstate, &len);
|
||||
table[i] = scm_makfromstr (mem, len, 0);
|
||||
}
|
||||
scm_restore_pad (dstate);
|
||||
return;
|
||||
}
|
||||
case scm_tc7_vector:
|
||||
{
|
||||
int i;
|
||||
for (i = 0; i < nobjs; i++)
|
||||
{
|
||||
int len = scm_restore_word (dstate);
|
||||
table[i] = scm_c_make_vector (len, SCM_BOOL_F);
|
||||
}
|
||||
return;
|
||||
}
|
||||
case scm_tc7_smob:
|
||||
{
|
||||
int i;
|
||||
SCM (*alloc) () = scm_smobs[SCM_TC2SMOBNUM(tc)].undump_alloc;
|
||||
if (!alloc)
|
||||
break;
|
||||
for (i = 0; i < nobjs; i++)
|
||||
table[i] = alloc (dstate);
|
||||
return;
|
||||
}
|
||||
}
|
||||
scm_misc_error ("scm_undump_alloc", "Cannot undump", SCM_EOL);
|
||||
}
|
||||
|
||||
static void
|
||||
scm_undump_restore (scm_bits_t tc, int nobjs, SCM *table, SCM dstate)
|
||||
#define FUNC_NAME "scm_undump_restore"
|
||||
{
|
||||
if (SCM_ITAG3 (SCM_PACK (tc)) == scm_tc3_cons)
|
||||
{
|
||||
int i;
|
||||
for (i = 0; i < nobjs; i++)
|
||||
{
|
||||
SCM obj = table[i];
|
||||
SCM_SETCAR (obj, scm_restore_object (dstate));
|
||||
SCM_SETCDR (obj, scm_restore_object (dstate));
|
||||
}
|
||||
return;
|
||||
}
|
||||
|
||||
switch (SCM_ITAG7 (SCM_PACK (tc)))
|
||||
{
|
||||
case scm_tc7_vector:
|
||||
{
|
||||
int i, j;
|
||||
for (i = 0; i < nobjs; i++)
|
||||
{
|
||||
SCM obj = table[i];
|
||||
int len = SCM_VECTOR_LENGTH (obj);
|
||||
SCM *base = SCM_VELTS (obj);
|
||||
for (j = 0; j < len; j++)
|
||||
base[j] = scm_restore_object (dstate);
|
||||
}
|
||||
return;
|
||||
}
|
||||
case scm_tc7_smob:
|
||||
{
|
||||
int i;
|
||||
void (*restore) () = scm_smobs[SCM_TC2SMOBNUM(tc)].undump_restore;
|
||||
if (restore)
|
||||
for (i = 0; i < nobjs; i++)
|
||||
restore (table[i], dstate);
|
||||
}
|
||||
}
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
static void
|
||||
scm_undump_init (scm_bits_t tc, int nobjs, SCM *table, SCM dstate)
|
||||
{
|
||||
if (SCM_ITAG7 (SCM_PACK (tc)) == scm_tc7_smob)
|
||||
{
|
||||
int i;
|
||||
void (*init) () = scm_smobs[SCM_TC2SMOBNUM(tc)].undump_init;
|
||||
if (init)
|
||||
for (i = 0; i < nobjs; i++)
|
||||
init (table[i]);
|
||||
}
|
||||
}
|
||||
|
||||
|
||||
/*
|
||||
* Scheme interface
|
||||
*/
|
||||
|
||||
#define DUMP_APPLY(f,nmeta,meta,table) \
|
||||
{ \
|
||||
int i; \
|
||||
int len = 0; \
|
||||
for (i = 0; i < nmeta; i++) \
|
||||
{ \
|
||||
f (meta[i].tc, meta[i].nobjs, table + len, dstate); \
|
||||
len += meta[i].nobjs; \
|
||||
} \
|
||||
}
|
||||
|
||||
static SCM
|
||||
scm_dump_table_fold (void *proc, SCM key, SCM data, SCM value)
|
||||
{
|
||||
SCM handle = scm_sloppy_assq (data, value);
|
||||
if (SCM_CONSP (handle))
|
||||
{
|
||||
SCM_SETCDR (handle, scm_cons (key, SCM_CDR (handle)));
|
||||
return value;
|
||||
}
|
||||
else
|
||||
return scm_acons (data, SCM_LIST1 (key), value);
|
||||
}
|
||||
|
||||
SCM_DEFINE (scm_binary_write, "binary-write", 1, 1, 0,
|
||||
(SCM obj, SCM port),
|
||||
"Write OBJ to PORT in a binary format.")
|
||||
#define FUNC_NAME s_scm_binary_write
|
||||
{
|
||||
int i, index, len, nmeta;
|
||||
struct scm_dump_header header;
|
||||
struct scm_dump_meta *meta;
|
||||
SCM dstate, alist, list, *base;
|
||||
|
||||
/* Check port */
|
||||
if (SCM_UNBNDP (port))
|
||||
port = scm_cur_outp;
|
||||
else
|
||||
SCM_VALIDATE_OUTPUT_PORT (2, port);
|
||||
|
||||
/* Mark objects */
|
||||
dstate = make_dstate ();
|
||||
SCM_DSTATE_TABLE (dstate) =
|
||||
scm_c_make_hash_table (SCM_DUMP_INITIAL_HASH_SIZE);
|
||||
scm_dump_mark (obj, dstate);
|
||||
|
||||
/* Build meta information */
|
||||
alist = scm_internal_hash_fold (scm_dump_table_fold, 0, SCM_EOL,
|
||||
SCM_DSTATE_TABLE (dstate));
|
||||
nmeta = scm_ilength (alist);
|
||||
meta = alloca (nmeta * sizeof (struct scm_dump_meta));
|
||||
list = alist;
|
||||
len = 0;
|
||||
for (i = 0; i < nmeta; i++)
|
||||
{
|
||||
meta[i].tc = SCM_INUM (SCM_CAAR (list));
|
||||
meta[i].nobjs = scm_ilength (SCM_CDAR (list));
|
||||
len += meta[i].nobjs;
|
||||
list = SCM_CDR (list);
|
||||
}
|
||||
|
||||
/* Build object table */
|
||||
SCM_DSTATE_TABLE (dstate) = scm_c_make_vector (len, SCM_BOOL_F);
|
||||
base = SCM_DSTATE_TABLE_BASE (dstate);
|
||||
index = 0;
|
||||
for (i = 0; i < nmeta; i++)
|
||||
{
|
||||
SCM list;
|
||||
for (list = SCM_CDAR (alist); !SCM_NULLP (list); list = SCM_CDR (list))
|
||||
base[index++] = SCM_CAR (list);
|
||||
alist = SCM_CDR (alist);
|
||||
}
|
||||
|
||||
/* Dump */
|
||||
DUMP_APPLY (scm_dump_dealloc, nmeta, meta, base);
|
||||
DUMP_APPLY (scm_dump_store, nmeta, meta, base);
|
||||
|
||||
/* Write header */
|
||||
header.cookie = ((scm_bits_t *) SCM_DUMP_COOKIE)[0];
|
||||
header.version = ((scm_bits_t *) SCM_DUMP_COOKIE)[1];
|
||||
header.nmeta = nmeta;
|
||||
header.init = scm_object_indicator (obj, dstate);
|
||||
scm_lfwrite ((const char *) &header, sizeof (struct scm_dump_header), port);
|
||||
|
||||
/* Write the rest */
|
||||
scm_lfwrite ((const char *) meta,
|
||||
nmeta * sizeof (struct scm_dump_meta),
|
||||
port);
|
||||
scm_lfwrite (SCM_DSTATE_DATA (dstate)->image_base,
|
||||
SCM_DSTATE_DATA (dstate)->image_index,
|
||||
port);
|
||||
|
||||
return SCM_UNSPECIFIED;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_binary_read, "binary-read", 0, 1, 0,
|
||||
(SCM port),
|
||||
"Read an object from PORT in a binary format.")
|
||||
#define FUNC_NAME s_scm_binary_read
|
||||
{
|
||||
int i, len;
|
||||
scm_bits_t *data;
|
||||
struct scm_dump_header *header;
|
||||
struct scm_dump_meta *meta;
|
||||
SCM dstate, *base;
|
||||
|
||||
/* Check port */
|
||||
if (SCM_UNBNDP (port))
|
||||
port = scm_cur_inp;
|
||||
else
|
||||
SCM_VALIDATE_INPUT_PORT (1, port);
|
||||
|
||||
/* Initialize */
|
||||
if (SCM_FPORTP (port))
|
||||
/* Undump with mmap */
|
||||
dstate = make_dstate_by_mmap (SCM_FPORT_FDES (port));
|
||||
else
|
||||
/* Undump with malloc */
|
||||
SCM_MISC_ERROR ("Not supported yet", SCM_EOL);
|
||||
|
||||
/* Read header */
|
||||
header = (struct scm_dump_header *) SCM_DSTATE_DATA (dstate)->image_base;
|
||||
if (SCM_DSTATE_DATA (dstate)->image_size < sizeof (*header))
|
||||
SCM_MISC_ERROR ("Invalid binary format: ~A", SCM_LIST1 (port));
|
||||
if (header->cookie != ((scm_bits_t *) SCM_DUMP_COOKIE)[0])
|
||||
SCM_MISC_ERROR ("Invalid binary format: ~A", SCM_LIST1 (port));
|
||||
if (header->version != ((scm_bits_t *) SCM_DUMP_COOKIE)[1])
|
||||
SCM_MISC_ERROR ("Unsupported binary version: ~A", SCM_LIST1 (port));
|
||||
|
||||
/* Read the rest */
|
||||
meta = (struct scm_dump_meta *) ((char *) header + sizeof (*header));
|
||||
data = (scm_bits_t *) (meta + header->nmeta);
|
||||
SCM_DSTATE_DATA (dstate)->image_index = (char *) data - (char *) header;
|
||||
|
||||
/* Create object table */
|
||||
len = 0;
|
||||
for (i = 0; i < header->nmeta; i++)
|
||||
len += meta[i].nobjs;
|
||||
SCM_DSTATE_TABLE (dstate) = scm_c_make_vector (len, SCM_BOOL_F);
|
||||
base = SCM_DSTATE_TABLE_BASE (dstate);
|
||||
|
||||
/* Undump */
|
||||
DUMP_APPLY (scm_undump_alloc, header->nmeta, meta, base);
|
||||
DUMP_APPLY (scm_undump_restore, header->nmeta, meta, base);
|
||||
DUMP_APPLY (scm_undump_init, header->nmeta, meta, base);
|
||||
|
||||
/* Return */
|
||||
{
|
||||
SCM obj = scm_indicator_object (header->init, dstate);
|
||||
SCM_DSTATE_TABLE (dstate) = SCM_BOOL_F;
|
||||
return obj;
|
||||
}
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
||||
void
|
||||
scm_init_dump ()
|
||||
{
|
||||
scm_tc16_dstate = scm_make_smob_type ("dstate", 0);
|
||||
scm_set_smob_mark (scm_tc16_dstate, dstate_mark);
|
||||
scm_set_smob_free (scm_tc16_dstate, dstate_free);
|
||||
#ifndef SCM_MAGIC_SNARFER
|
||||
#include "libguile/dump.x"
|
||||
#endif
|
||||
}
|
||||
|
||||
/*
|
||||
Local Variables:
|
||||
c-file-style: "gnu"
|
||||
End:
|
||||
*/
|
69
libguile/dump.h
Normal file
69
libguile/dump.h
Normal file
|
@ -0,0 +1,69 @@
|
|||
/* classes: h_files */
|
||||
|
||||
#ifndef DUMPH
|
||||
#define DUMPH
|
||||
/* Copyright (C) 2001 Free Software Foundation, Inc.
|
||||
*
|
||||
* 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, 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 software; see the file COPYING. If not, write to
|
||||
* the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
|
||||
* Boston, MA 02111-1307 USA
|
||||
*
|
||||
* As a special exception, the Free Software Foundation gives permission
|
||||
* for additional uses of the text contained in its release of GUILE.
|
||||
*
|
||||
* The exception is that, if you link the GUILE library with other files
|
||||
* to produce an executable, this does not by itself cause the
|
||||
* resulting executable to be covered by the GNU General Public License.
|
||||
* Your use of that executable is in no way restricted on account of
|
||||
* linking the GUILE library code into it.
|
||||
*
|
||||
* This exception does not however invalidate any other reasons why
|
||||
* the executable file might be covered by the GNU General Public License.
|
||||
*
|
||||
* This exception applies only to the code released by the
|
||||
* Free Software Foundation under the name GUILE. If you copy
|
||||
* code from other Free Software Foundation releases into a copy of
|
||||
* GUILE, as the General Public License permits, the exception does
|
||||
* not apply to the code that you add in this way. To avoid misleading
|
||||
* anyone as to the status of such modified files, you must delete
|
||||
* this exception notice from them.
|
||||
*
|
||||
* If you write modifications of your own for GUILE, it is your choice
|
||||
* whether to permit this exception to apply to your modifications.
|
||||
* If you do not wish that, delete this exception notice. */
|
||||
|
||||
#include "libguile/__scm.h"
|
||||
|
||||
extern void scm_dump_mark (SCM obj, SCM dstate);
|
||||
extern void scm_store_string (const char *addr, scm_sizet size, SCM dstate);
|
||||
extern void scm_store_bytes (const char *addr, scm_sizet size, SCM dstate);
|
||||
extern void scm_store_word (const scm_bits_t word, SCM dstate);
|
||||
extern void scm_store_object (SCM obj, SCM dstate);
|
||||
extern const char *scm_restore_string (SCM dstate, int *lenp);
|
||||
extern const char *scm_restore_bytes (SCM dstate, scm_sizet size);
|
||||
extern scm_bits_t scm_restore_word (SCM dstate);
|
||||
extern SCM scm_restore_object (SCM dstate);
|
||||
|
||||
extern SCM scm_binary_write (SCM obj, SCM port);
|
||||
extern SCM scm_binary_read (SCM port);
|
||||
|
||||
extern void scm_init_dump (void);
|
||||
|
||||
#endif /* DUMPH */
|
||||
|
||||
/*
|
||||
Local Variables:
|
||||
c-file-style: "gnu"
|
||||
End:
|
||||
*/
|
|
@ -66,6 +66,7 @@
|
|||
#ifdef GUILE_DEBUG_MALLOC
|
||||
#include "libguile/debug-malloc.h"
|
||||
#endif
|
||||
#include "libguile/dump.h"
|
||||
#include "libguile/dynl.h"
|
||||
#include "libguile/dynwind.h"
|
||||
#include "libguile/environments.h"
|
||||
|
@ -197,7 +198,7 @@ start_stack (void *base)
|
|||
/* Create the look-aside stack for variables that are shared between
|
||||
* captured continuations.
|
||||
*/
|
||||
scm_continuation_stack = scm_make_vector (SCM_MAKINUM (512), SCM_UNDEFINED);
|
||||
scm_continuation_stack = scm_c_make_vector (512, SCM_UNDEFINED);
|
||||
/* The continuation stack is further initialized by restart_stack. */
|
||||
|
||||
/* The remainder of stack initialization is factored out to another
|
||||
|
@ -493,6 +494,7 @@ scm_init_guile_1 (SCM_STACKITEM *base)
|
|||
#ifdef GUILE_DEBUG_MALLOC
|
||||
scm_init_debug_malloc ();
|
||||
#endif
|
||||
scm_init_dump ();
|
||||
scm_init_dynwind ();
|
||||
scm_init_eq ();
|
||||
scm_init_error ();
|
||||
|
|
|
@ -51,6 +51,7 @@
|
|||
#include "libguile/ports.h"
|
||||
#include "libguile/root.h"
|
||||
#include "libguile/smob.h"
|
||||
#include "libguile/dump.h"
|
||||
#include "libguile/hashtab.h"
|
||||
|
||||
#include "libguile/validate.h"
|
||||
|
@ -67,6 +68,23 @@ keyword_print (SCM exp, SCM port, scm_print_state *pstate)
|
|||
return 1;
|
||||
}
|
||||
|
||||
static void
|
||||
keyword_dealloc (SCM obj, SCM dstate)
|
||||
{
|
||||
SCM sym = scm_keyword_dash_symbol (obj);
|
||||
scm_store_string (SCM_SYMBOL_CHARS (sym),
|
||||
SCM_SYMBOL_LENGTH (sym),
|
||||
dstate);
|
||||
}
|
||||
|
||||
static SCM
|
||||
keyword_alloc (SCM dstate)
|
||||
{
|
||||
int len;
|
||||
const char *mem = scm_restore_string (dstate, &len);
|
||||
SCM sym = scm_mem2symbol (mem, len);
|
||||
return scm_make_keyword_from_dash_symbol (sym);
|
||||
}
|
||||
|
||||
SCM_DEFINE (scm_make_keyword_from_dash_symbol, "make-keyword-from-dash-symbol", 1, 0, 0,
|
||||
(SCM symbol),
|
||||
|
@ -138,6 +156,8 @@ scm_init_keywords ()
|
|||
scm_tc16_keyword = scm_make_smob_type ("keyword", 0);
|
||||
scm_set_smob_mark (scm_tc16_keyword, scm_markcdr);
|
||||
scm_set_smob_print (scm_tc16_keyword, keyword_print);
|
||||
scm_set_smob_dump (scm_tc16_keyword, 0, keyword_dealloc, 0);
|
||||
scm_set_smob_undump (scm_tc16_keyword, keyword_alloc, 0, 0);
|
||||
|
||||
scm_keyword_obarray = scm_c_make_hash_table (256);
|
||||
#ifndef SCM_MAGIC_SNARFER
|
||||
|
|
|
@ -288,18 +288,24 @@ scm_make_smob_type (char *name, scm_sizet size)
|
|||
if (tmp)
|
||||
{
|
||||
scm_smobs = (scm_smob_descriptor *) tmp;
|
||||
scm_smobs[scm_numsmob].name = name;
|
||||
scm_smobs[scm_numsmob].size = size;
|
||||
scm_smobs[scm_numsmob].mark = 0;
|
||||
scm_smobs[scm_numsmob].free = (size == 0 ? scm_free0 : scm_smob_free);
|
||||
scm_smobs[scm_numsmob].print = scm_smob_print;
|
||||
scm_smobs[scm_numsmob].equalp = 0;
|
||||
scm_smobs[scm_numsmob].apply = 0;
|
||||
scm_smobs[scm_numsmob].name = name;
|
||||
scm_smobs[scm_numsmob].size = size;
|
||||
scm_smobs[scm_numsmob].mark = 0;
|
||||
scm_smobs[scm_numsmob].free = (size == 0 ? scm_free0 : scm_smob_free);
|
||||
scm_smobs[scm_numsmob].print = scm_smob_print;
|
||||
scm_smobs[scm_numsmob].equalp = 0;
|
||||
scm_smobs[scm_numsmob].apply = 0;
|
||||
scm_smobs[scm_numsmob].apply_0 = 0;
|
||||
scm_smobs[scm_numsmob].apply_1 = 0;
|
||||
scm_smobs[scm_numsmob].apply_2 = 0;
|
||||
scm_smobs[scm_numsmob].apply_3 = 0;
|
||||
scm_smobs[scm_numsmob].gsubr_type = 0;
|
||||
scm_smobs[scm_numsmob].gsubr_type = 0;
|
||||
scm_smobs[scm_numsmob].dump_mark = 0;
|
||||
scm_smobs[scm_numsmob].dump_dealloc = 0;
|
||||
scm_smobs[scm_numsmob].dump_store = 0;
|
||||
scm_smobs[scm_numsmob].undump_alloc = 0;
|
||||
scm_smobs[scm_numsmob].undump_restore = 0;
|
||||
scm_smobs[scm_numsmob].undump_init = 0;
|
||||
scm_numsmob++;
|
||||
}
|
||||
SCM_ALLOW_INTS;
|
||||
|
@ -316,31 +322,31 @@ scm_make_smob_type (char *name, scm_sizet size)
|
|||
}
|
||||
|
||||
void
|
||||
scm_set_smob_mark (long tc, SCM (*mark) (SCM))
|
||||
scm_set_smob_mark (scm_bits_t tc, SCM (*mark) (SCM))
|
||||
{
|
||||
scm_smobs[SCM_TC2SMOBNUM (tc)].mark = mark;
|
||||
}
|
||||
|
||||
void
|
||||
scm_set_smob_free (long tc, scm_sizet (*free) (SCM))
|
||||
scm_set_smob_free (scm_bits_t tc, scm_sizet (*free) (SCM))
|
||||
{
|
||||
scm_smobs[SCM_TC2SMOBNUM (tc)].free = free;
|
||||
}
|
||||
|
||||
void
|
||||
scm_set_smob_print (long tc, int (*print) (SCM, SCM, scm_print_state*))
|
||||
scm_set_smob_print (scm_bits_t tc, int (*print) (SCM, SCM, scm_print_state*))
|
||||
{
|
||||
scm_smobs[SCM_TC2SMOBNUM (tc)].print = print;
|
||||
}
|
||||
|
||||
void
|
||||
scm_set_smob_equalp (long tc, SCM (*equalp) (SCM, SCM))
|
||||
scm_set_smob_equalp (scm_bits_t tc, SCM (*equalp) (SCM, SCM))
|
||||
{
|
||||
scm_smobs[SCM_TC2SMOBNUM (tc)].equalp = equalp;
|
||||
}
|
||||
|
||||
void
|
||||
scm_set_smob_apply (long tc, SCM (*apply) (),
|
||||
scm_set_smob_apply (scm_bits_t tc, SCM (*apply) (),
|
||||
unsigned int req, unsigned int opt, unsigned int rst)
|
||||
{
|
||||
SCM (*apply_0) (SCM);
|
||||
|
@ -441,7 +447,7 @@ scm_set_smob_apply (long tc, SCM (*apply) (),
|
|||
apply_3 = scm_smob_apply_3_error; break;
|
||||
}
|
||||
|
||||
scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply;
|
||||
scm_smobs[SCM_TC2SMOBNUM (tc)].apply = apply;
|
||||
scm_smobs[SCM_TC2SMOBNUM (tc)].apply_0 = apply_0;
|
||||
scm_smobs[SCM_TC2SMOBNUM (tc)].apply_1 = apply_1;
|
||||
scm_smobs[SCM_TC2SMOBNUM (tc)].apply_2 = apply_2;
|
||||
|
@ -449,8 +455,30 @@ scm_set_smob_apply (long tc, SCM (*apply) (),
|
|||
scm_smobs[SCM_TC2SMOBNUM (tc)].gsubr_type = type;
|
||||
}
|
||||
|
||||
void
|
||||
scm_set_smob_dump (scm_bits_t tc,
|
||||
SCM (*mark) (SCM, SCM),
|
||||
void (*dealloc) (SCM, SCM),
|
||||
void (*store) (SCM, SCM))
|
||||
{
|
||||
scm_smobs[SCM_TC2SMOBNUM (tc)].dump_mark = mark;
|
||||
scm_smobs[SCM_TC2SMOBNUM (tc)].dump_dealloc = dealloc;
|
||||
scm_smobs[SCM_TC2SMOBNUM (tc)].dump_store = store;
|
||||
}
|
||||
|
||||
void
|
||||
scm_set_smob_undump (scm_bits_t tc,
|
||||
SCM (*alloc) (SCM),
|
||||
void (*restore) (SCM, SCM),
|
||||
void (*init) (SCM))
|
||||
{
|
||||
scm_smobs[SCM_TC2SMOBNUM (tc)].undump_alloc = alloc;
|
||||
scm_smobs[SCM_TC2SMOBNUM (tc)].undump_restore = restore;
|
||||
scm_smobs[SCM_TC2SMOBNUM (tc)].undump_init = init;
|
||||
}
|
||||
|
||||
SCM
|
||||
scm_make_smob (long tc)
|
||||
scm_make_smob (scm_bits_t tc)
|
||||
{
|
||||
int n = SCM_TC2SMOBNUM (tc);
|
||||
scm_sizet size = scm_smobs[n].size;
|
||||
|
|
|
@ -53,16 +53,28 @@ typedef struct scm_smob_descriptor
|
|||
{
|
||||
char *name;
|
||||
scm_sizet size;
|
||||
|
||||
/* Basic functions */
|
||||
SCM (*mark) (SCM);
|
||||
scm_sizet (*free) (SCM);
|
||||
int (*print) (SCM exp, SCM port, scm_print_state *pstate);
|
||||
SCM (*equalp) (SCM, SCM);
|
||||
|
||||
/* Apply functions */
|
||||
SCM (*apply) ();
|
||||
SCM (*apply_0) (SCM);
|
||||
SCM (*apply_1) (SCM, SCM);
|
||||
SCM (*apply_2) (SCM, SCM, SCM);
|
||||
SCM (*apply_3) (SCM, SCM, SCM, SCM);
|
||||
int gsubr_type; /* Used in procprop.c */
|
||||
|
||||
/* Dump functions */
|
||||
SCM (*dump_mark) (SCM, SCM);
|
||||
void (*dump_dealloc) (SCM, SCM);
|
||||
void (*dump_store) (SCM, SCM);
|
||||
SCM (*undump_alloc) (SCM);
|
||||
void (*undump_restore) (SCM, SCM);
|
||||
void (*undump_init) (SCM);
|
||||
} scm_smob_descriptor;
|
||||
|
||||
|
||||
|
@ -145,20 +157,31 @@ extern int scm_smob_print (SCM exp, SCM port, scm_print_state *pstate);
|
|||
|
||||
extern scm_bits_t scm_make_smob_type (char *name, scm_sizet size);
|
||||
|
||||
extern void scm_set_smob_mark (long tc, SCM (*mark) (SCM));
|
||||
extern void scm_set_smob_free (long tc, scm_sizet (*free) (SCM));
|
||||
extern void scm_set_smob_print (long tc, int (*print) (SCM,
|
||||
SCM,
|
||||
scm_print_state*));
|
||||
extern void scm_set_smob_equalp (long tc, SCM (*equalp) (SCM, SCM));
|
||||
extern void scm_set_smob_apply (long tc, SCM (*apply) (),
|
||||
extern void scm_set_smob_mark (scm_bits_t tc,
|
||||
SCM (*mark) (SCM));
|
||||
extern void scm_set_smob_free (scm_bits_t tc,
|
||||
scm_sizet (*free) (SCM));
|
||||
extern void scm_set_smob_print (scm_bits_t tc,
|
||||
int (*print) (SCM, SCM, scm_print_state*));
|
||||
extern void scm_set_smob_equalp (scm_bits_t tc,
|
||||
SCM (*equalp) (SCM, SCM));
|
||||
extern void scm_set_smob_apply (scm_bits_t tc,
|
||||
SCM (*apply) (),
|
||||
unsigned int req,
|
||||
unsigned int opt,
|
||||
unsigned int rst);
|
||||
extern void scm_set_smob_dump (scm_bits_t tc,
|
||||
SCM (*mark) (SCM, SCM),
|
||||
void (*dealloc) (SCM, SCM),
|
||||
void (*store) (SCM, SCM));
|
||||
extern void scm_set_smob_undump (scm_bits_t tc,
|
||||
SCM (*alloc) (SCM),
|
||||
void (*restore) (SCM, SCM),
|
||||
void (*init) (SCM));
|
||||
|
||||
/* Function for creating smobs */
|
||||
|
||||
extern SCM scm_make_smob (long tc);
|
||||
extern SCM scm_make_smob (scm_bits_t tc);
|
||||
extern void scm_smob_prehistory (void);
|
||||
|
||||
|
||||
|
|
Loading…
Add table
Add a link
Reference in a new issue