summaryrefslogtreecommitdiff
path: root/libguile/struct.c
diff options
context:
space:
mode:
authorGreg J. Badros <gjb@cs.washington.edu>1999-12-12 02:36:16 +0000
committerGreg J. Badros <gjb@cs.washington.edu>1999-12-12 02:36:16 +0000
commit1bbd0b849f6b90f1ffe57e586e4ee5a884f84a11 (patch)
tree79120a96365e0fa3324174bfd08d731ca8311d64 /libguile/struct.c
parent6e7069385db8cf96dfbe51cf65ace161942a32c9 (diff)
downloadguile-1bbd0b849f6b90f1ffe57e586e4ee5a884f84a11.tar.gz
* *.c: Pervasive software-engineering-motivated rewrite of
function headers and argument checking. Switched SCM_PROC, SCM_PROC1 macros to be GUILE_PROC, GUILE_PROC1 (may change names later, but was useful to keep old versions around while migrate) that has docstrings and argument lists embedded in the GUILE_PROC macro invocations that expand into a function header. Use lots of new SCM_VALIDATE_* macros to simplify error checking and reduce tons of redundancy. This is very similar to what I did for Scwm. Note that none of the extraction of the docstrings, nor software engineering checks of Scwm is yet added to Guile. I'll work on that tomorrow, I expect. * Makefile.am: Added scm_validate.h to modinclude_HEADERS. * chars.c: Added docstrings for the primitives defined in here. * snarf.h: Added GUILE_PROC, GUILE_PROC1. Added SCM_REGISTER_PROC to be like old SCM_PROC, though old SCM_PROC still remains for now. Changed naming convention for the s_foo string name of the primitive to be s_scm_foo for ease of use with the macro. * scm_validate.h: Lots of new SCM_VALIDATE macros to simplify argument checking through guile. Maybe some of these should be folded into the header file for the types they check, but for now it was easiest to just stick them all in one place.
Diffstat (limited to 'libguile/struct.c')
-rw-r--r--libguile/struct.c220
1 files changed, 97 insertions, 123 deletions
diff --git a/libguile/struct.c b/libguile/struct.c
index b9136449a..289c83ec1 100644
--- a/libguile/struct.c
+++ b/libguile/struct.c
@@ -38,6 +38,10 @@
* 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. */
+
+/* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
+ gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
+
#include <stdio.h>
@@ -49,6 +53,7 @@
#include "weaks.h"
#include "hashtab.h"
+#include "scm_validate.h"
#include "struct.h"
#ifdef HAVE_STRING_H
@@ -61,24 +66,21 @@ static SCM required_vtable_fields = SCM_BOOL_F;
SCM scm_struct_table;
-SCM_PROC (s_struct_make_layout, "make-struct-layout", 1, 0, 0, scm_make_struct_layout);
-
-SCM
-scm_make_struct_layout (fields)
- SCM fields;
+GUILE_PROC (scm_make_struct_layout, "make-struct-layout", 1, 0, 0,
+ (SCM fields),
+"")
+#define FUNC_NAME s_scm_make_struct_layout
{
SCM new_sym;
- SCM_ASSERT (SCM_NIMP (fields) && SCM_ROSTRINGP (fields),
- fields, SCM_ARG1, s_struct_make_layout);
-
- {
+ SCM_VALIDATE_ROSTRING(1,fields);
+ { /* scope */
char * field_desc;
int len;
int x;
len = SCM_ROLENGTH (fields);
field_desc = SCM_ROCHARS (fields);
- SCM_ASSERT (!(len & 1), fields, "odd length field specification", s_struct_make_layout);
+ SCM_ASSERT (!(len & 1), fields, "odd length field specification", FUNC_NAME);
for (x = 0; x < len; x += 2)
{
@@ -93,14 +95,14 @@ scm_make_struct_layout (fields)
case 's':
break;
default:
- SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized field type", s_struct_make_layout);
+ SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized field type", FUNC_NAME);
}
switch (field_desc[x + 1])
{
case 'w':
SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]),
- "self fields not writable", s_struct_make_layout);
+ "self fields not writable", FUNC_NAME);
case 'r':
case 'o':
@@ -110,18 +112,18 @@ scm_make_struct_layout (fields)
case 'O':
SCM_ASSERT (field_desc[x] != 's', SCM_MAKICHR (field_desc[x + 1]),
"self fields not allowed in tail array",
- s_struct_make_layout);
+ FUNC_NAME);
SCM_ASSERT (x == len - 2, SCM_MAKICHR (field_desc[x + 1]),
"tail array field must be last field in layout",
- s_struct_make_layout);
+ FUNC_NAME);
break;
default:
- SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized ref specification", s_struct_make_layout);
+ SCM_ASSERT (0, SCM_MAKICHR (field_desc[x]) , "unrecognized ref specification", FUNC_NAME);
}
#if 0
if (field_desc[x] == 'd')
{
- SCM_ASSERT (field_desc[x + 2] == '-', SCM_MAKINUM (x / 2), "missing dash field", s_struct_make_layout);
+ SCM_ASSERT (field_desc[x + 2] == '-', SCM_MAKINUM (x / 2), "missing dash field", FUNC_NAME);
x += 2;
goto recheck_ref;
}
@@ -131,16 +133,14 @@ scm_make_struct_layout (fields)
}
return scm_return_first (new_sym, fields);
}
+#undef FUNC_NAME
void
-scm_struct_init (handle, tail_elts, inits)
- SCM handle;
- int tail_elts;
- SCM inits;
+scm_struct_init (SCM handle, int tail_elts, SCM inits)
{
SCM layout;
SCM * data;
@@ -231,22 +231,19 @@ scm_struct_init (handle, tail_elts, inits)
}
-SCM_PROC (s_struct_p, "struct?", 1, 0, 0, scm_struct_p);
-
-SCM
-scm_struct_p (x)
- SCM x;
+GUILE_PROC (scm_struct_p, "struct?", 1, 0, 0,
+ (SCM x),
+"")
+#define FUNC_NAME s_scm_struct_p
{
- return ((SCM_NIMP (x) && SCM_STRUCTP (x))
- ? SCM_BOOL_T
- : SCM_BOOL_F);
+ return SCM_BOOL(SCM_NIMP (x) && SCM_STRUCTP (x));
}
+#undef FUNC_NAME
-SCM_PROC (s_struct_vtable_p, "struct-vtable?", 1, 0, 0, scm_struct_vtable_p);
-
-SCM
-scm_struct_vtable_p (x)
- SCM x;
+GUILE_PROC (scm_struct_vtable_p, "struct-vtable?", 1, 0, 0,
+ (SCM x),
+"")
+#define FUNC_NAME s_scm_struct_vtable_p
{
SCM layout;
SCM * mem;
@@ -274,10 +271,9 @@ scm_struct_vtable_p (x)
if (SCM_IMP (mem[0]))
return SCM_BOOL_F;
- return (SCM_SYMBOLP (mem[0])
- ? SCM_BOOL_T
- : SCM_BOOL_F);
+ return SCM_BOOL(SCM_SYMBOLP (mem[0]));
}
+#undef FUNC_NAME
/* All struct data must be allocated at an address whose bottom three
@@ -362,13 +358,10 @@ scm_struct_free_entity (SCM *vtable, SCM *data)
return n;
}
-SCM_PROC (s_make_struct, "make-struct", 2, 0, 1, scm_make_struct);
-
-SCM
-scm_make_struct (vtable, tail_array_size, init)
- SCM vtable;
- SCM tail_array_size;
- SCM init;
+GUILE_PROC (scm_make_struct, "make-struct", 2, 0, 1,
+ (SCM vtable, SCM tail_array_size, SCM init),
+ "")
+#define FUNC_NAME s_scm_make_struct
{
SCM layout;
int basic_size;
@@ -376,10 +369,8 @@ scm_make_struct (vtable, tail_array_size, init)
SCM * data;
SCM handle;
- SCM_ASSERT ((SCM_BOOL_F != scm_struct_vtable_p (vtable)),
- vtable, SCM_ARG1, s_make_struct);
- SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2,
- s_make_struct);
+ SCM_VALIDATE_VTABLE(1,vtable);
+ SCM_VALIDATE_INT(2,tail_array_size);
layout = SCM_STRUCT_DATA (vtable)[scm_vtable_index_layout];
basic_size = SCM_LENGTH (layout) / 2;
@@ -404,16 +395,14 @@ scm_make_struct (vtable, tail_array_size, init)
SCM_ALLOW_INTS;
return handle;
}
+#undef FUNC_NAME
-SCM_PROC (s_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1, scm_make_vtable_vtable);
-
-SCM
-scm_make_vtable_vtable (extra_fields, tail_array_size, init)
- SCM extra_fields;
- SCM tail_array_size;
- SCM init;
+GUILE_PROC (scm_make_vtable_vtable, "make-vtable-vtable", 2, 0, 1,
+ (SCM extra_fields, SCM tail_array_size, SCM init),
+"")
+#define FUNC_NAME s_scm_make_vtable_vtable
{
SCM fields;
SCM layout;
@@ -422,10 +411,8 @@ scm_make_vtable_vtable (extra_fields, tail_array_size, init)
SCM * data;
SCM handle;
- SCM_ASSERT (SCM_NIMP (extra_fields) && SCM_ROSTRINGP (extra_fields),
- extra_fields, SCM_ARG1, s_make_vtable_vtable);
- SCM_ASSERT (SCM_INUMP (tail_array_size), tail_array_size, SCM_ARG2,
- s_make_vtable_vtable);
+ SCM_VALIDATE_ROSTRING(1,extra_fields);
+ SCM_VALIDATE_INT(2,tail_array_size);
fields = scm_string_append (scm_listify (required_vtable_fields,
extra_fields,
@@ -445,16 +432,15 @@ scm_make_vtable_vtable (extra_fields, tail_array_size, init)
SCM_ALLOW_INTS;
return handle;
}
+#undef FUNC_NAME
-SCM_PROC (s_struct_ref, "struct-ref", 2, 0, 0, scm_struct_ref);
-
-SCM
-scm_struct_ref (handle, pos)
- SCM handle;
- SCM pos;
+GUILE_PROC (scm_struct_ref, "struct-ref", 2, 0, 0,
+ (SCM handle, SCM pos),
+"")
+#define FUNC_NAME s_scm_struct_ref
{
SCM answer = SCM_UNDEFINED;
SCM * data;
@@ -465,9 +451,8 @@ scm_struct_ref (handle, pos)
unsigned char field_type = 0;
- SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
- SCM_ARG1, s_struct_ref);
- SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);
+ SCM_VALIDATE_STRUCT(1,handle);
+ SCM_VALIDATE_INT(2,pos);
layout = SCM_STRUCT_LAYOUT (handle);
data = SCM_STRUCT_DATA (handle);
@@ -476,7 +461,7 @@ scm_struct_ref (handle, pos)
fields_desc = (unsigned char *) SCM_CHARS (layout);
n_fields = data[scm_struct_i_n_words];
- SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_ref);
+ SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, FUNC_NAME);
if (p * 2 < SCM_LENGTH (layout))
{
@@ -488,14 +473,14 @@ scm_struct_ref (handle, pos)
if ((ref == 'R') || (ref == 'W'))
field_type = 'u';
else
- SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
+ SCM_ASSERT (0, pos, "ref denied", FUNC_NAME);
}
}
else if (fields_desc[SCM_LENGTH (layout) - 1] != 'O')
field_type = fields_desc[SCM_LENGTH (layout) - 2];
else
{
- SCM_ASSERT (0, pos, "ref denied", s_struct_ref);
+ SCM_ASSERT (0, pos, "ref denied", FUNC_NAME);
abort ();
}
@@ -522,21 +507,19 @@ scm_struct_ref (handle, pos)
default:
- SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_ref);
+ SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", FUNC_NAME);
break;
}
return answer;
}
+#undef FUNC_NAME
-SCM_PROC (s_struct_set_x, "struct-set!", 3, 0, 0, scm_struct_set_x);
-
-SCM
-scm_struct_set_x (handle, pos, val)
- SCM handle;
- SCM pos;
- SCM val;
+GUILE_PROC (scm_struct_set_x, "struct-set!", 3, 0, 0,
+ (SCM handle, SCM pos, SCM val),
+"")
+#define FUNC_NAME s_scm_struct_set_x
{
SCM * data;
SCM layout;
@@ -544,12 +527,9 @@ scm_struct_set_x (handle, pos, val)
int n_fields;
unsigned char * fields_desc;
unsigned char field_type = 0;
-
-
- SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
- SCM_ARG1, s_struct_ref);
- SCM_ASSERT (SCM_INUMP (pos), pos, SCM_ARG2, s_struct_ref);
+ SCM_VALIDATE_STRUCT(1,handle);
+ SCM_VALIDATE_INT(2,pos);
layout = SCM_STRUCT_LAYOUT (handle);
data = SCM_STRUCT_DATA (handle);
@@ -558,7 +538,7 @@ scm_struct_set_x (handle, pos, val)
fields_desc = (unsigned char *)SCM_CHARS (layout);
n_fields = data[scm_struct_i_n_words];
- SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, s_struct_set_x);
+ SCM_ASSERT (p < n_fields, pos, SCM_OUTOFRANGE, FUNC_NAME);
if (p * 2 < SCM_LENGTH (layout))
{
@@ -566,25 +546,25 @@ scm_struct_set_x (handle, pos, val)
field_type = fields_desc[p * 2];
set_x = fields_desc [p * 2 + 1];
if (set_x != 'w')
- SCM_ASSERT (0, pos, "set_x denied", s_struct_set_x);
+ SCM_ASSERT (0, pos, "set_x denied", FUNC_NAME);
}
else if (fields_desc[SCM_LENGTH (layout) - 1] == 'W')
field_type = fields_desc[SCM_LENGTH (layout) - 2];
else
{
- SCM_ASSERT (0, pos, "set_x denied", s_struct_ref);
+ SCM_ASSERT (0, pos, "set_x denied", FUNC_NAME);
abort ();
}
switch (field_type)
{
case 'u':
- data[p] = (SCM)scm_num2ulong (val, (char *)SCM_ARG3, s_struct_set_x);
+ data[p] = SCM_NUM2ULONG (3,val);
break;
#if 0
case 'i':
- data[p] = scm_num2long (val, (char *)SCM_ARG3, s_struct_set_x);
+ data[p] = SCM_NUM2LONG (3,val);
break;
case 'd':
@@ -597,40 +577,39 @@ scm_struct_set_x (handle, pos, val)
break;
case 's':
- SCM_ASSERT (0, SCM_MAKICHR (field_type), "self fields immutable", s_struct_set_x);
+ SCM_ASSERT (0, SCM_MAKICHR (field_type), "self fields immutable", FUNC_NAME);
break;
default:
- SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", s_struct_set_x);
+ SCM_ASSERT (0, SCM_MAKICHR (field_type), "unrecognized field type", FUNC_NAME);
break;
}
return val;
}
+#undef FUNC_NAME
-SCM_PROC (s_struct_vtable, "struct-vtable", 1, 0, 0, scm_struct_vtable);
-
-SCM
-scm_struct_vtable (handle)
- SCM handle;
+GUILE_PROC (scm_struct_vtable, "struct-vtable", 1, 0, 0,
+ (SCM handle),
+"")
+#define FUNC_NAME s_scm_struct_vtable
{
- SCM_ASSERT (SCM_NIMP (handle) && SCM_STRUCTP (handle), handle,
- SCM_ARG1, s_struct_vtable);
+ SCM_VALIDATE_STRUCT(1,handle);
return SCM_STRUCT_VTABLE (handle);
}
+#undef FUNC_NAME
-SCM_PROC (s_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0, scm_struct_vtable_tag);
-
-SCM
-scm_struct_vtable_tag (handle)
- SCM handle;
+GUILE_PROC (scm_struct_vtable_tag, "struct-vtable-tag", 1, 0, 0,
+ (SCM handle),
+"")
+#define FUNC_NAME s_scm_struct_vtable_tag
{
- SCM_ASSERT (SCM_NFALSEP (scm_struct_vtable_p (handle)),
- handle, SCM_ARG1, s_struct_vtable_tag);
+ SCM_VALIDATE_VTABLE(1,handle);
return scm_long2num ((long) SCM_STRUCT_DATA (handle) >> 3);
}
+#undef FUNC_NAME
/* {Associating names and classes with vtables}
*
@@ -661,39 +640,34 @@ scm_struct_create_handle (SCM obj)
return handle;
}
-SCM_PROC (s_struct_vtable_name, "struct-vtable-name", 1, 0, 0, scm_struct_vtable_name);
-
-SCM
-scm_struct_vtable_name (SCM vtable)
+GUILE_PROC (scm_struct_vtable_name, "struct-vtable-name", 1, 0, 0,
+ (SCM vtable),
+ "")
+#define FUNC_NAME s_scm_struct_vtable_name
{
- SCM_ASSERT (SCM_NFALSEP (scm_struct_vtable_p (vtable)),
- vtable, SCM_ARG1, s_struct_vtable_name);
-
+ SCM_VALIDATE_VTABLE(1,vtable);
return SCM_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)));
}
+#undef FUNC_NAME
-SCM_PROC (s_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0, scm_set_struct_vtable_name_x);
-
-SCM
-scm_set_struct_vtable_name_x (SCM vtable, SCM name)
+GUILE_PROC (scm_set_struct_vtable_name_x, "set-struct-vtable-name!", 2, 0, 0,
+ (SCM vtable, SCM name),
+ "")
+#define FUNC_NAME s_scm_set_struct_vtable_name_x
{
- SCM_ASSERT (SCM_NIMP (vtable) && SCM_NFALSEP (scm_struct_vtable_p (vtable)),
- vtable, SCM_ARG1, s_set_struct_vtable_name_x);
- SCM_ASSERT (SCM_NIMP (name) && SCM_SYMBOLP (name),
- name, SCM_ARG2, s_set_struct_vtable_name_x);
+ SCM_VALIDATE_VTABLE(1,vtable);
+ SCM_VALIDATE_SYMBOL(2,name);
SCM_SET_STRUCT_TABLE_NAME (SCM_CDR (scm_struct_create_handle (vtable)),
name);
return SCM_UNSPECIFIED;
}
+#undef FUNC_NAME
void
-scm_print_struct (exp, port, pstate)
- SCM exp;
- SCM port;
- scm_print_state *pstate;
+scm_print_struct (SCM exp, SCM port, scm_print_state *pstate)
{
if (SCM_NFALSEP (scm_procedure_p (SCM_STRUCT_PRINTER (exp))))
scm_printer_apply (SCM_STRUCT_PRINTER (exp), exp, port, pstate);