-/* Copyright (C) 1996, 97, 98, 99, 2000 Free Software Foundation, Inc.
+/* Copyright (C) 1996,1997,1998,1999,2000,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
\f
-#include <stdio.h>
#include "libguile/_scm.h"
#include "libguile/chars.h"
#include "libguile/eval.h"
{
SCM new_sym;
SCM_VALIDATE_STRING (1, fields);
+
{ /* scope */
char * field_desc;
- int len;
+ scm_sizet len;
int x;
len = SCM_STRING_LENGTH (fields);
- field_desc = SCM_ROCHARS (fields);
- SCM_ASSERT (!(len & 1), fields, "odd length field specification", FUNC_NAME);
+ if (len % 2 == 1)
+ SCM_MISC_ERROR ("odd length field specification: ~S",
+ SCM_LIST1 (fields));
+
+ field_desc = SCM_STRING_CHARS (fields);
for (x = 0; x < len; x += 2)
{
case 's':
break;
default:
- SCM_ASSERT (0, SCM_MAKE_CHAR (field_desc[x]) , "unrecognized field type", FUNC_NAME);
+ SCM_MISC_ERROR ("unrecognized field type: ~S",
+ SCM_LIST1 (SCM_MAKE_CHAR (field_desc[x])));
}
switch (field_desc[x + 1])
{
case 'w':
- SCM_ASSERT (field_desc[x] != 's', SCM_MAKE_CHAR (field_desc[x + 1]),
- "self fields not writable", FUNC_NAME);
-
+ if (field_desc[x] == 's')
+ SCM_MISC_ERROR ("self fields not writable", SCM_EOL);
case 'r':
case 'o':
break;
case 'R':
case 'W':
case 'O':
- SCM_ASSERT (field_desc[x] != 's', SCM_MAKE_CHAR (field_desc[x + 1]),
- "self fields not allowed in tail array",
- FUNC_NAME);
- SCM_ASSERT (x == len - 2, SCM_MAKE_CHAR (field_desc[x + 1]),
- "tail array field must be last field in layout",
- FUNC_NAME);
+ if (field_desc[x] == 's')
+ SCM_MISC_ERROR ("self fields not allowed in tail array",
+ SCM_EOL);
+ if (x != len - 2)
+ SCM_MISC_ERROR ("tail array field must be last field in layout",
+ SCM_EOL);
break;
default:
- SCM_ASSERT (0, SCM_MAKE_CHAR (field_desc[x]) , "unrecognized ref specification", FUNC_NAME);
+ SCM_MISC_ERROR ("unrecognized ref specification: ~S",
+ SCM_LIST1 (SCM_MAKE_CHAR (field_desc[x + 1])));
}
#if 0
if (field_desc[x] == 'd')
{
- SCM_ASSERT (field_desc[x + 2] == '-', SCM_MAKINUM (x / 2), "missing dash field", FUNC_NAME);
+ if (field_desc[x + 2] != '-')
+ SCM_MISC_ERROR ("missing dash field at position ~A",
+ SCM_LIST1 (SCM_MAKINUM (x / 2)));
x += 2;
goto recheck_ref;
}
#endif
}
- new_sym = SCM_CAR (scm_intern_obarray (field_desc, len, SCM_BOOL_F));
+ new_sym = scm_mem2symbol (field_desc, len);
}
return scm_return_first (new_sym, fields);
}
SCM_DEFINE (scm_struct_p, "struct?", 1, 0, 0,
(SCM x),
- "Return #t iff @var{obj} is a structure object, else #f.")
+ "Return @code{#t} iff @var{obj} is a structure object, else\n"
+ "@code{#f}.")
#define FUNC_NAME s_scm_struct_p
{
return SCM_BOOL(SCM_STRUCTP (x));
SCM_DEFINE (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,
(SCM x),
- "Return #t iff obj is a vtable structure.")
+ "Return @code{#t} iff obj is a vtable structure.")
#define FUNC_NAME s_scm_struct_vtable_p
{
SCM layout;
{
/* Mark vtables in GC chain. GC mark set means delay freeing. */
SCM chain = newchain;
- while (SCM_NNULLP (chain))
+ while (!SCM_NULLP (chain))
{
SCM vtable = SCM_STRUCT_VTABLE (chain);
if (SCM_STRUCT_GC_CHAIN (vtable) != 0 && vtable != chain)
/* Free unmarked structs. */
chain = newchain;
newchain = SCM_EOL;
- while (SCM_NNULLP (chain))
+ while (!SCM_NULLP (chain))
{
SCM obj = chain;
chain = SCM_STRUCT_GC_CHAIN (chain);
scm_bits_t word0 = SCM_CELL_WORD_0 (obj) - scm_tc3_cons_gloc;
/* access as struct */
scm_bits_t * vtable_data = (scm_bits_t *) word0;
- scm_bits_t * data = (scm_bits_t *) SCM_UNPACK (SCM_CDR (obj));
+ scm_bits_t * data = SCM_STRUCT_DATA (obj);
scm_struct_free_t free_struct_data
= ((scm_struct_free_t) vtable_data[scm_struct_i_free]);
SCM_SET_CELL_TYPE (obj, scm_tc_free_cell);
}
}
}
- while (SCM_NNULLP (newchain));
+ while (!SCM_NULLP (newchain));
return 0;
}
"sub-system: one vtable-vtable working as the root and one or several\n"
"\"types\", each with a set of \"instances\". (The vtable-vtable should be\n"
"compared to the class <class> which is the class of itself.)\n\n"
- "@example\n"
+ "@lisp\n"
"(define ball-root (make-vtable-vtable \"pr\" 0))\n\n"
"(define (make-ball-type ball-color)\n"
" (make-struct ball-root 0\n"
"(define (make-ball type owner) (make-struct type 0 owner))\n\n"
"(define ball (make-ball green 'Nisse))\n"
"ball @result{} #<a green ball owned by Nisse>\n"
- "@end example\n"
- "")
+ "@end lisp\n")
#define FUNC_NAME s_scm_make_vtable_vtable
{
SCM fields;
SCM_VALIDATE_INUM (2, tail_array_size);
SCM_VALIDATE_REST_ARGUMENT (init);
- fields = scm_string_append (scm_listify (required_vtable_fields,
- user_fields,
- SCM_UNDEFINED));
+ fields = scm_string_append (SCM_LIST2 (required_vtable_fields, user_fields));
layout = scm_make_struct_layout (fields);
basic_size = SCM_SYMBOL_LENGTH (layout) / 2;
tail_elts = SCM_INUM (tail_array_size);
SCM layout;
int p;
scm_bits_t n_fields;
- unsigned char * fields_desc;
- unsigned char field_type = 0;
+ char * fields_desc;
+ char field_type = 0;
SCM_VALIDATE_STRUCT (1,handle);
data = SCM_STRUCT_DATA (handle);
p = SCM_INUM (pos);
- fields_desc = SCM_SYMBOL_UCHARS (layout);
+ fields_desc = SCM_SYMBOL_CHARS (layout);
n_fields = data[scm_struct_i_n_words];
SCM_ASSERT_RANGE(1,pos, p < n_fields);
if (p * 2 < SCM_SYMBOL_LENGTH (layout))
{
- unsigned char ref;
+ char ref;
field_type = fields_desc[p * 2];
ref = fields_desc[p * 2 + 1];
if ((ref != 'r') && (ref != 'w'))
if ((ref == 'R') || (ref == 'W'))
field_type = 'u';
else
- SCM_ASSERT (0, pos, "ref denied", FUNC_NAME);
+ SCM_MISC_ERROR ("ref denied for field ~A", SCM_LIST1 (pos));
}
}
else if (fields_desc[SCM_SYMBOL_LENGTH (layout) - 1] != 'O')
field_type = fields_desc[SCM_SYMBOL_LENGTH (layout) - 2];
else
- {
- SCM_ASSERT (0, pos, "ref denied", FUNC_NAME);
- abort ();
- }
+ SCM_MISC_ERROR ("ref denied for field ~A", SCM_LIST1 (pos));
switch (field_type)
{
default:
- SCM_ASSERT (0, SCM_MAKE_CHAR (field_type), "unrecognized field type", FUNC_NAME);
- break;
+ SCM_MISC_ERROR ("unrecognized field type: ~S",
+ SCM_LIST1 (SCM_MAKE_CHAR (field_type)));
}
return answer;
SCM_DEFINE (scm_struct_set_x, "struct-set!", 3, 0, 0,
(SCM handle, SCM pos, SCM val),
- "")
+ "Set the slot of the structure @var{handle} with index @var{pos}\n"
+ "to @var{val}. Signal an error if the slot can not be written\n"
+ "to.")
#define FUNC_NAME s_scm_struct_set_x
{
scm_bits_t * data;
SCM layout;
int p;
int n_fields;
- unsigned char * fields_desc;
- unsigned char field_type = 0;
+ char * fields_desc;
+ char field_type = 0;
SCM_VALIDATE_STRUCT (1,handle);
SCM_VALIDATE_INUM (2,pos);
data = SCM_STRUCT_DATA (handle);
p = SCM_INUM (pos);
- fields_desc = SCM_SYMBOL_UCHARS (layout);
+ fields_desc = SCM_SYMBOL_CHARS (layout);
n_fields = data[scm_struct_i_n_words];
SCM_ASSERT_RANGE (1,pos, p < n_fields);
if (p * 2 < SCM_SYMBOL_LENGTH (layout))
{
- unsigned char set_x;
+ char set_x;
field_type = fields_desc[p * 2];
set_x = fields_desc [p * 2 + 1];
if (set_x != 'w')
- SCM_ASSERT (0, pos, "set_x denied", FUNC_NAME);
+ SCM_MISC_ERROR ("set! denied for field ~A", SCM_LIST1 (pos));
}
else if (fields_desc[SCM_SYMBOL_LENGTH (layout) - 1] == 'W')
field_type = fields_desc[SCM_SYMBOL_LENGTH (layout) - 2];
else
- {
- SCM_ASSERT (0, pos, "set_x denied", FUNC_NAME);
- abort ();
- }
+ SCM_MISC_ERROR ("set! denied for field ~A", SCM_LIST1 (pos));
switch (field_type)
{
#if 0
case 'i':
- data[p] = SCM_NUM2LONG (3,val);
+ data[p] = SCM_NUM2LONG (3, val);
break;
case 'd':
break;
case 's':
- SCM_ASSERT (0, SCM_MAKE_CHAR (field_type), "self fields immutable", FUNC_NAME);
- break;
+ SCM_MISC_ERROR ("self fields immutable", SCM_EOL);
default:
- SCM_ASSERT (0, SCM_MAKE_CHAR (field_type), "unrecognized field type", FUNC_NAME);
- break;
+ SCM_MISC_ERROR ("unrecognized field type: ~S",
+ SCM_LIST1 (SCM_MAKE_CHAR (field_type)));
}
return val;
SCM_DEFINE (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0,
(SCM handle),
- "")
+ "Return the vtable tag of the structure @var{handle}.")
#define FUNC_NAME s_scm_struct_vtable_tag
{
SCM_VALIDATE_VTABLE (1,handle);
SCM_DEFINE (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0,
(SCM vtable),
- "")
+ "Return the name of the vtable @var{vtable}.")
#define FUNC_NAME s_scm_struct_vtable_name
{
SCM_VALIDATE_VTABLE (1,vtable);
SCM_DEFINE (scm_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0,
(SCM vtable, SCM name),
- "")
+ "Set the name of the vtable @var{vtable} to @var{name}.")
#define FUNC_NAME s_scm_set_struct_vtable_name_x
{
SCM_VALIDATE_VTABLE (1,vtable);
HCoop / bpt / guile.git / blobdiff