mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-10 14:00:21 +02:00
Code Activity

* Minor docstring updates.

Browse source
This commit is contained in:
Neil Jerram 2001-02-23 20:24:15 +00:00
parent 19b6a58d52
commit 2069af3835
5 changed files with 18 additions and 646 deletions
Download patch file Download diff file Expand all files Collapse all files

10
libguile/ChangeLog
View file

@ -1,6 +1,13 @@
2001-02-23 Neil Jerram <neil@ossau.uklinux.net>
* dump.c (scm_binary_write, scm_binary_read), eval.c
(scm_primitive_eval), guardians.c (scm_guardian_destroyed_p,
scm_guardian_greedy_p, scm_make_guardian), fports.c
(scm_file_port_p): Minor docstring fixes.
2001-02-22 Marius Vollmer <mvo@zagadka.ping.de>
* load.c (load): Use scm_primtive_eval_x instead of scm_i_eval_x.
* load.c (load): Use scm_primitive_eval_x instead of scm_i_eval_x.
* goops.c (scm_add_method, DEFVAR): Use scm_eval instead of
scm_i_eval.
@ -33,6 +40,7 @@
* guile-doc-snarf.in, guile-func-name-check.in: Added copyright
notice and license.
>>>>>>> 1.1281
2001-02-17 Martin Grabmueller <mgrabmue@cs.tu-berlin.de>
* variable.c (scm_make_variable, scm_make_undefined_variable)

636
libguile/dump.c
View file

@ -1,636 +0,0 @@
/* 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.1"
#define SCM_DUMP_HASH_SIZE 151
#define SCM_DUMP_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 nobjs; /* the number of objects */
/* or immediate value */
};
/*
* 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 */
int table_index;
SCM table; /* Object table */
SCM task; /* Update task */
};
#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_REF(d,i) (SCM_VELTS (SCM_DSTATE_TABLE (d))[i])
#define SCM_DSTATE_TABLE_SET(d,i,x) (SCM_VELTS (SCM_DSTATE_TABLE (d))[i] = (x))
#define SCM_DSTATE_TASK(d) (SCM_DSTATE_DATA (d)->task)
#define SCM_DTASK_ID(t) ((scm_bits_t) SCM_CELL_WORD_1 (t))
#define SCM_DTASK_ADDR(t) ((scm_bits_t *) SCM_CELL_WORD_2 (t))
#define SCM_DTASK_NEXT(t) (SCM_CELL_OBJECT_3 (t))
#define SCM_SET_DTASK_ID(t,x) SCM_SET_CELL_WORD_1 (t, x)
#define SCM_SET_DTASK_ADDR(t,x) SCM_SET_CELL_WORD_2 (t, x)
#define SCM_SET_DTASK_NEXT(t,x) SCM_SET_CELL_OBJECT_3 (t, x)
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_IMAGE_SIZE;
p->image_index = 0;
p->image_base = SCM_MUST_MALLOC (p->image_size);
p->table_index = 0;
p->table = SCM_BOOL_F;
p->task = SCM_EOL;
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_index = 0;
p->table = SCM_BOOL_F;
p->task = SCM_EOL;
SCM_RETURN_NEWSMOB (scm_tc16_dstate, p);
}
#undef FUNC_NAME
static SCM
dstate_mark (SCM obj)
{
SCM task;
struct scm_dstate *p = SCM_DSTATE_DATA (obj);
for (task = p->task; !SCM_NULLP (task); task = SCM_DTASK_NEXT (task))
scm_gc_mark (task);
return p->table;
}
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);
/* Free dump image */
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
{
SCM id = scm_hashq_ref (SCM_DSTATE_TABLE (dstate), obj, SCM_BOOL_F);
if (SCM_FALSEP (id))
return -1;
else
return SCM_DUMP_INDEX_TO_WORD (SCM_INUM (id));
}
}
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_REF (dstate, SCM_DUMP_WORD_TO_INDEX (word));
}
/*
* Dump interface
*/
/* store functions */
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';
}
void
scm_store_word (const scm_bits_t word, SCM dstate)
{
struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
while (p->image_index + sizeof (scm_bits_t) >= p->image_size)
dstate_extend (p);
memcpy (p->image_base + p->image_index, &word, sizeof (scm_bits_t));
p->image_index += sizeof (scm_bits_t);
}
void
scm_store_bytes (const void *addr, scm_sizet size, SCM dstate)
{
struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
scm_store_word (size, dstate);
while (p->image_index + size + sizeof (scm_bits_t) >= 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_string (const char *addr, scm_sizet size, SCM dstate)
{
struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
while (p->image_index + size + 1 >= 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;
scm_store_pad (dstate);
}
void
scm_store_object (SCM obj, SCM dstate)
{
scm_bits_t id = scm_object_indicator (obj, dstate);
if (id == -1)
{
/* OBJ is not stored yet. Do it later */
struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
SCM task;
SCM_NEWCELL2 (task);
SCM_SET_DTASK_ID (task, SCM_UNPACK (obj));
SCM_SET_DTASK_ADDR (task, p->image_index);
SCM_SET_DTASK_NEXT (task, p->task);
p->task = task;
}
scm_store_word (id, dstate);
}
/* restore functions */
static void
scm_restore_pad (struct scm_dstate *p)
{
while (p->image_index % sizeof (scm_bits_t) != 0)
p->image_index++;
}
void
scm_restore_word (scm_bits_t *wordp, SCM dstate)
{
struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
*wordp = *(scm_bits_t *) (p->image_base + p->image_index);
p->image_index += sizeof (scm_bits_t);
}
void
scm_restore_bytes (const void **pp, scm_sizet *sizep, SCM dstate)
{
scm_bits_t size;
struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
scm_restore_word (&size, dstate);
if (sizep)
*sizep = size;
*pp = p->image_base + p->image_index;
p->image_index += size;
scm_restore_pad (p);
}
void
scm_restore_string (const char **pp, scm_sizet *sizep, SCM dstate)
{
int len;
struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
*pp = p->image_base + p->image_index;
len = strlen (*pp);
if (sizep)
*sizep = len;
p->image_index += len + 1;
scm_restore_pad (p);
}
void
scm_restore_object (SCM *objp, SCM dstate)
{
scm_bits_t id;
scm_restore_word (&id, dstate);
*objp = scm_indicator_object (id, dstate);
if (SCM_UNBNDP (*objp))
{
struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
SCM task;
SCM_NEWCELL2 (task);
SCM_SET_DTASK_ID (task, id);
SCM_SET_DTASK_ADDR (task, objp);
SCM_SET_DTASK_NEXT (task, p->task);
p->task = task;
}
}
/*
* Dump routine
*/
static void
scm_dump (SCM obj, SCM dstate)
{
struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
/* Check if immediate or already dumpped */
if (scm_object_indicator (obj, dstate) != -1)
return;
/* Mark it */
scm_hashq_set_x (p->table, obj, SCM_MAKINUM (p->table_index));
p->table_index++;
if (SCM_SLOPPY_CONSP (obj))
{
scm_store_word (scm_tc3_cons, dstate);
/* Store cdr first in order to avoid a possible deep recursion
* with a long list */
scm_store_object (SCM_CDR (obj), dstate);
scm_store_object (SCM_CAR (obj), dstate);
goto next_dump;
}
switch (SCM_TYP7 (obj))
{
case scm_tc7_symbol:
{
scm_store_word (scm_tc7_symbol, dstate);
scm_store_string (SCM_SYMBOL_CHARS (obj),
SCM_SYMBOL_LENGTH (obj),
dstate);
return;
}
case scm_tc7_substring:
case scm_tc7_string:
{
scm_store_word (scm_tc7_string, dstate);
scm_store_string (SCM_STRING_CHARS (obj),
SCM_STRING_LENGTH (obj),
dstate);
return;
}
case scm_tc7_vector:
{
int i;
scm_bits_t len = SCM_VECTOR_LENGTH (obj);
SCM *base = SCM_VELTS (obj);
scm_store_word (scm_tc7_vector, dstate);
scm_store_word (len, dstate);
for (i = 0; i < len; i++)
scm_store_object (base[i], dstate);
goto next_dump;
}
case scm_tc7_smob:
{
void (*dump) () = SCM_SMOB_DESCRIPTOR (obj).dump;
if (!dump)
goto error;
/* FIXME: SCM_CELL_TYPE may change when undump!! */
scm_store_word (SCM_CELL_TYPE (obj), dstate);
dump (obj, dstate);
goto next_dump;
}
default:
error:
scm_misc_error ("scm_dump_mark", "Cannot dump: ~A", SCM_LIST1 (obj));
}
next_dump:
{
SCM task;
for (task = p->task; !SCM_NULLP (task); task = SCM_DTASK_NEXT (task))
{
SCM obj = SCM_PACK (SCM_DTASK_ID (task));
scm_dump (obj, dstate);
*(scm_bits_t *) (p->image_base + (int) SCM_DTASK_ADDR (task)) =
scm_object_indicator (obj, dstate);
}
}
}
static void
scm_undump (SCM dstate)
{
struct scm_dstate *p = SCM_DSTATE_DATA (dstate);
scm_bits_t tc;
SCM obj;
scm_restore_word (&tc, dstate);
if (SCM_ITAG3 (SCM_PACK (tc)) == scm_tc3_cons)
{
SCM_NEWCELL (obj);
/* cdr was stored first */
scm_restore_object (SCM_CDRLOC (obj), dstate);
scm_restore_object (SCM_CARLOC (obj), dstate);
goto store_object;
}
switch (SCM_ITAG7 (SCM_PACK (tc)))
{
case scm_tc7_symbol:
{
scm_sizet len;
const char *mem;
scm_restore_string (&mem, &len, dstate);
obj = scm_mem2symbol (mem, len);
goto store_object;
}
case scm_tc7_string:
{
scm_sizet len;
const char *mem;
scm_restore_string (&mem, &len, dstate);
obj = scm_makfromstr (mem, len, 0);
goto store_object;
}
case scm_tc7_vector:
{
int i;
scm_bits_t len;
SCM *base;
scm_restore_word (&len, dstate);
obj = scm_c_make_vector (len, SCM_BOOL_F);
base = SCM_VELTS (obj);
for (i = 0; i < len; i++)
scm_restore_object (&base[i], dstate);
goto store_object;
}
case scm_tc7_smob:
{
SCM (*undump) () = scm_smobs[SCM_TC2SMOBNUM (tc)].undump;
if (!undump)
goto error;
obj = undump (dstate);
goto store_object;
}
default:
error:
scm_misc_error ("scm_undump", "Cannot undump", SCM_EOL);
}
store_object:
SCM_DSTATE_TABLE_SET (dstate, p->table_index, obj);
p->table_index++;
}
/*
* Scheme interface
*/
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
{
struct scm_dstate *p;
struct scm_dump_header header;
SCM dstate;
/* Check port */
if (SCM_UNBNDP (port))
port = scm_cur_outp;
else
SCM_VALIDATE_OUTPUT_PORT (2, port);
/* Dump objects */
dstate = make_dstate ();
p = SCM_DSTATE_DATA (dstate);
p->table = scm_c_make_hash_table (SCM_DUMP_HASH_SIZE);
scm_dump (obj, dstate);
/* Write image */
header.cookie = ((scm_bits_t *) SCM_DUMP_COOKIE)[0];
header.version = ((scm_bits_t *) SCM_DUMP_COOKIE)[1];
header.nobjs = (p->table_index
? SCM_DUMP_INDEX_TO_WORD (p->table_index)
: SCM_UNPACK (obj));
scm_lfwrite ((const char *) &header, sizeof (struct scm_dump_header), port);
if (p->image_index)
scm_lfwrite (p->image_base, p->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, nobjs;
struct scm_dstate *p;
struct scm_dump_header *header;
SCM dstate;
/* 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);
p = SCM_DSTATE_DATA (dstate);
/* Read header */
header = (struct scm_dump_header *) p->image_base;
p->image_index += sizeof (struct scm_dump_header);
if (p->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));
/* Check for immediate */
if (SCM_IMP (SCM_PACK (header->nobjs)))
return SCM_PACK (header->nobjs);
/* Create object table */
nobjs = SCM_DUMP_WORD_TO_INDEX (header->nobjs);
p->table = scm_c_make_vector (nobjs, SCM_UNDEFINED);
/* Undump */
for (i = 0; i < nobjs; i++)
scm_undump (dstate);
/* Update references */
{
SCM task;
for (task = p->task; !SCM_NULLP (task); task = SCM_DTASK_NEXT (task))
{
*SCM_DTASK_ADDR (task) =
SCM_UNPACK (scm_indicator_object (SCM_DTASK_ID (task), dstate));
}
}
/* Return */
{
SCM obj = SCM_DSTATE_TABLE_REF (dstate, 0);
p->table = 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:
*/

2
libguile/eval.c
View file

@ -3880,7 +3880,7 @@ scm_primitive_eval_x (SCM exp)
SCM_DEFINE (scm_primitive_eval, "primitive-eval", 1, 0, 0,
(SCM exp),
"Evaluate @var{epx} in the top-level environment specified by\n"
"Evaluate @var{exp} in the top-level environment specified by\n"
"the current module.")
#define FUNC_NAME s_scm_primitive_eval
{

2
libguile/fports.c
View file

@ -229,7 +229,7 @@ scm_evict_ports (int fd)
SCM_DEFINE (scm_file_port_p, "file-port?", 1, 0, 0,
(SCM obj),
"Determine whether OBJ is a port that is related to a file.")
"Determine whether @var{obj} is a port that is related to a file.")
#define FUNC_NAME s_scm_file_port_p
{
return SCM_BOOL (SCM_FPORTP (obj));

14
libguile/guardians.c
View file

@ -313,17 +313,17 @@ SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 1, 0,
"A guardian protects a set of objects from garbage collection,\n"
"allowing a program to apply cleanup or other actions.\n\n"
"make-guardian returns a procedure representing the guardian.\n"
"@code{make-guardian} returns a procedure representing the guardian.\n"
"Calling the guardian procedure with an argument adds the\n"
"argument to the guardian's set of protected objects.\n"
"Calling the guardian procedure without an argument returns\n"
"one of the protected objects which are ready for garbage\n"
"collection or @code{#f} if no such object is available.\n"
"collection, or @code{#f} if no such object is available.\n"
"Objects which are returned in this way are removed from\n"
"the guardian.\n\n"
"make-guardian takes one optional argument that says whether the\n"
"new guardian should be greedy or sharing. if there is any chance\n"
"@code{make-guardian} takes one optional argument that says whether the\n"
"new guardian should be greedy or sharing. If there is any chance\n"
"that any object protected by the guardian may be resurrected,\n"
"then you should make the guardian greedy (this is the default).\n\n"
@ -361,7 +361,7 @@ SCM_DEFINE (scm_make_guardian, "make-guardian", 0, 1, 0,
SCM_DEFINE (scm_guardian_destroyed_p, "guardian-destroyed?", 1, 0, 0,
(SCM guardian),
"Is @var{guardian} destroyed?")
"Return @code{#t} if @var{guardian} has been destroyed, otherwise @code{#f}.")
#define FUNC_NAME s_scm_guardian_destroyed_p
{
SCM res = SCM_BOOL_F;
@ -377,9 +377,9 @@ SCM_DEFINE (scm_guardian_destroyed_p, "guardian-destroyed?", 1, 0, 0,
}
#undef FUNC_NAME
SCM_DEFINE (scm_guardian_greedy_p, "guardian_greedy?", 1, 0, 0,
SCM_DEFINE (scm_guardian_greedy_p, "guardian-greedy?", 1, 0, 0,
(SCM guardian),
"Is @var{guardian} greedy?")
"Return @code{#t} if @var{guardian} is a greedy guardian, otherwise @code{#f}.\n")
#define FUNC_NAME s_scm_guardian_greedy_p
{
return SCM_BOOL (GREEDY_P (GUARDIAN (guardian)));