Skip to content

Commit

Permalink
further condition class hierarchy support
Browse files Browse the repository at this point in the history 
git-svn-id: https://gauche.svn.sourceforge.net/svnroot/gauche/Gauche/trunk@4664 c205566b-fb4e-0410-ab5c-8f0660156277
  • Loading branch information
@shirok
shirok committed Oct 10, 2004
1 parent a526cb3 commit 1257330
Show file tree
Hide file tree
Showing 10 changed files with 222 additions and 107 deletions.
11 changes: 11 additions & 0 deletions ChangeLog
View file
Original file line number Diff line number Diff line change
@@ -1,13 +1,24 @@
2004-10-09 Shiro Kawai <shiro@acm.org>


* src/port.c, src/portapi.c : revised to use Scm_PortError instead
of Scm_Error when appropriate.
* src/read.c : replaced some Scm_Error by Scm_ReadError.
* src/class.c (Scm_InitStaticClassWithMeta): exported for tricky
use, if the builtin class wants to control both metaclasses and
superclasses.
(Scm_ObjectAllocate): expose object_allocate so that
other C-defined placeholding "base" class (i.e. classes only
introduced for inheritance, but does not introduce C-specific
slots) can be used as a a superclass of other C-defined classes.
* src/error.c (Scm_PortError): added utility function.
(Scm_PrintDefaultErrorHeading): use condition's class name to
display the error message heading.
(Scm_ConditionTypeName): for convenicne.
* src/exclib.stub : some srfi-35 procedures.
* src/vm.c (Scm_VMThrowException): changed the non-continuable
exception check according to the new condition hierarchy.
* test/exception.scm : modified according to the recent change.

2004-10-08 Shiro Kawai <shiro@acm.org>

Expand Down
24 changes: 12 additions & 12 deletions ext/uvector/uvinit.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -30,7 +30,7 @@
* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* $Id: uvinit.c,v 1.6 2004-10-09 11:36:37 shirok Exp $
* $Id: uvinit.c,v 1.7 2004-10-10 09:52:09 shirok Exp $
*/

#include <gauche.h>
Expand Down Expand Up @@ -82,17 +82,17 @@ void Scm_Init_libgauche_uvector(void)

SCM_INIT_EXTENSION(uvector);
m = SCM_MODULE(SCM_FIND_MODULE("gauche.uvector", TRUE));
Scm__InitStaticClassWithMeta(&Scm_UVectorClass, "<uvector>", m, NULL, 0);
Scm__InitStaticClassWithMeta(&Scm_S8VectorClass, "<s8vector>", m, NULL, 0);
Scm__InitStaticClassWithMeta(&Scm_U8VectorClass, "<u8vector>", m, NULL, 0);
Scm__InitStaticClassWithMeta(&Scm_S16VectorClass, "<s16vector>", m, NULL, 0);
Scm__InitStaticClassWithMeta(&Scm_U16VectorClass, "<u16vector>", m, NULL, 0);
Scm__InitStaticClassWithMeta(&Scm_S32VectorClass, "<s32vector>", m, NULL, 0);
Scm__InitStaticClassWithMeta(&Scm_U32VectorClass, "<u32vector>", m, NULL, 0);
Scm__InitStaticClassWithMeta(&Scm_S64VectorClass, "<s64vector>", m, NULL, 0);
Scm__InitStaticClassWithMeta(&Scm_U64VectorClass, "<u64vector>", m, NULL, 0);
Scm__InitStaticClassWithMeta(&Scm_F32VectorClass, "<f32vector>", m, NULL, 0);
Scm__InitStaticClassWithMeta(&Scm_F64VectorClass, "<f64vector>", m, NULL, 0);
Scm_InitStaticClassWithMeta(&Scm_UVectorClass, "<uvector>", m, NULL, SCM_NIL, NULL, 0);
Scm_InitStaticClassWithMeta(&Scm_S8VectorClass, "<s8vector>", m, NULL, SCM_NIL, NULL, 0);
Scm_InitStaticClassWithMeta(&Scm_U8VectorClass, "<u8vector>", m, NULL, SCM_NIL, NULL, 0);
Scm_InitStaticClassWithMeta(&Scm_S16VectorClass, "<s16vector>", m, NULL, SCM_NIL, NULL, 0);
Scm_InitStaticClassWithMeta(&Scm_U16VectorClass, "<u16vector>", m, NULL, SCM_NIL, NULL, 0);
Scm_InitStaticClassWithMeta(&Scm_S32VectorClass, "<s32vector>", m, NULL, SCM_NIL, NULL, 0);
Scm_InitStaticClassWithMeta(&Scm_U32VectorClass, "<u32vector>", m, NULL, SCM_NIL, NULL, 0);
Scm_InitStaticClassWithMeta(&Scm_S64VectorClass, "<s64vector>", m, NULL, SCM_NIL, NULL, 0);
Scm_InitStaticClassWithMeta(&Scm_U64VectorClass, "<u64vector>", m, NULL, SCM_NIL, NULL, 0);
Scm_InitStaticClassWithMeta(&Scm_F32VectorClass, "<f32vector>", m, NULL, SCM_NIL, NULL, 0);
Scm_InitStaticClassWithMeta(&Scm_F64VectorClass, "<f64vector>", m, NULL, SCM_NIL, NULL, 0);

/* initialize constant values */
t = Scm_Ash(SCM_MAKE_INT(1), 31); /* 2^31 */
Expand Down
4 changes: 2 additions & 2 deletions lib/gauche/test.scm
View file
Original file line number Diff line number Diff line change
Expand Up @@ -30,7 +30,7 @@
;;; NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
;;; SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
;;;
;;; $Id: test.scm,v 1.13 2004-05-20 04:50:33 shirok Exp $
;;; $Id: test.scm,v 1.14 2004-10-10 09:52:09 shirok Exp $

;; Writing your own test
;;
Expand Down Expand Up @@ -119,7 +119,7 @@
(when *test-report-error*
(report-error e))
(make <test-error>
:message (if (is-a? e <error>)
:message (if (is-a? e <message-condition>)
(ref e 'message)
e)))
thunk))
Expand Down
69 changes: 40 additions & 29 deletions src/class.c
View file
Original file line number Diff line number Diff line change
Expand Up @@ -30,7 +30,7 @@
* NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
* SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
*
* $Id: class.c,v 1.114 2004-10-09 11:36:37 shirok Exp $
* $Id: class.c,v 1.115 2004-10-10 09:52:09 shirok Exp $
*/

#define LIBGAUCHE_BODY
Expand All @@ -53,7 +53,6 @@ static void accessor_method_print(ScmObj, ScmPort *, ScmWriteContext*);
static ScmObj class_allocate(ScmClass *klass, ScmObj initargs);
static ScmObj generic_allocate(ScmClass *klass, ScmObj initargs);
static ScmObj method_allocate(ScmClass *klass, ScmObj initargs);
static ScmObj object_allocate(ScmClass *k, ScmObj initargs);
static ScmObj slot_accessor_allocate(ScmClass *klass, ScmObj initargs);
static void initialize_builtin_cpl(ScmClass *klass, ScmObj supers);

Expand Down Expand Up @@ -105,7 +104,7 @@ SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_CharClass, NULL);
SCM_DEFINE_BUILTIN_CLASS_SIMPLE(Scm_UnknownClass, NULL);

SCM_DEFINE_BASE_CLASS(Scm_ObjectClass, ScmInstance,
NULL, NULL, NULL, object_allocate,
NULL, NULL, NULL, Scm_ObjectAllocate,
SCM_CLASS_DEFAULT_CPL);

/* Basic metaobjects */
Expand Down Expand Up @@ -534,7 +533,7 @@ static void class_cpl_set(ScmClass *klass, ScmObj val)
klass->allocate = NULL;
for (p = klass->cpa; *p; p++) {
if ((*p)->allocate) {
if ((*p)->allocate != object_allocate) {
if ((*p)->allocate != Scm_ObjectAllocate) {
if (klass->allocate && klass->allocate != (*p)->allocate) {
Scm_Error("class precedence list has more than one C-defined base class (except <object>): %S", val);
}
Expand All @@ -552,7 +551,7 @@ static void class_cpl_set(ScmClass *klass, ScmObj val)
Scm_Error("class precedence list doesn't have a base class: %S", val);
}
if (!klass->allocate) {
klass->allocate = object_allocate; /* default */
klass->allocate = Scm_ObjectAllocate; /* default */
klass->coreSize = sizeof(ScmInstance);
}
if (applicable) {
Expand Down Expand Up @@ -1785,7 +1784,7 @@ static void slot_accessor_scheme_boundp_set(ScmSlotAccessor *sa, ScmObj p)
* <object> class initialization
*/

static ScmObj object_allocate(ScmClass *klass, ScmObj initargs)
ScmObj Scm_ObjectAllocate(ScmClass *klass, ScmObj initargs)
{
ScmObj obj = Scm_AllocateInstance(klass, sizeof(ScmInstance));
SCM_SET_CLASS(obj, klass);
Expand Down Expand Up @@ -2721,30 +2720,42 @@ void Scm_InitStaticClassWithSupers(ScmClass *klass,
}

/* A special initialization for some of builtin classes.
Creates metaclass automatically. Extensions shouldn't use
this function; the implicit metaclass would be removed in future */
void Scm__InitStaticClassWithMeta(ScmClass *klass,
const char *name,
ScmModule *mod,
ScmClassStaticSlotSpec *specs,
int flags)
{
int nlen;
char *metaname;

init_class(klass, name, mod, SCM_FALSE, specs, flags);

nlen = strlen(name);
metaname = SCM_NEW_ATOMIC2(char *, nlen + 6);
Sets klass's metaclass to META. If META is NULL, a new metaclass
(whose name has "-meta" after the original class name except brackets)
is created automatically. This procedure should be only if
metaclass is absolutely required (e.g. all condition classes should
be an instance of <condition-meta>). The older version of Gauche
has metaclasses for many builtin classes, which is a compensation of
lack of eqv-method specializer; such use of metaclass is deprecated
and will be removed in future. */
void Scm_InitStaticClassWithMeta(ScmClass *klass,
const char *name,
ScmModule *mod,
ScmClass *meta,
ScmObj supers,
ScmClassStaticSlotSpec *specs,
int flags)
{
init_class(klass, name, mod, supers, specs, flags);

if (name[nlen - 1] == '>') {
strncpy(metaname, name, nlen-1);
strcpy(metaname+nlen-1, "-meta>");
if (meta) {
SCM_SET_CLASS(klass, meta);
} else {
strcpy(metaname, name);
strcat(metaname, "-meta");
int nlen;
char *metaname;

nlen = strlen(name);
metaname = SCM_NEW_ATOMIC2(char *, nlen + 6);

if (name[nlen - 1] == '>') {
strncpy(metaname, name, nlen-1);
strcpy(metaname+nlen-1, "-meta>");
} else {
strcpy(metaname, name);
strcat(metaname, "-meta");
}
SCM_SET_CLASS(klass, make_implicit_meta(metaname, klass->cpa, mod));
}
SCM_SET_CLASS(klass, make_implicit_meta(metaname, klass->cpa, mod));
}

/* The old API - deprecated. We keep this around for a while
Expand All @@ -2754,7 +2765,7 @@ void Scm_InitBuiltinClass(ScmClass *klass, const char *name,
int withMeta, ScmModule *mod)
{
if (withMeta) {
Scm__InitStaticClassWithMeta(klass, name, mod, specs, 0);
Scm_InitStaticClassWithMeta(klass, name, mod, NULL, SCM_FALSE, specs, 0);
} else {
Scm_InitStaticClass(klass, name, mod, specs, 0);
}
Expand Down Expand Up @@ -2803,7 +2814,7 @@ void Scm__InitClass(void)
Scm_InitStaticClass(cl, nam, mod, slots, 0)

#define CINIT(cl, nam) \
Scm__InitStaticClassWithMeta(cl, nam, mod, NULL, 0)
Scm_InitStaticClassWithMeta(cl, nam, mod, NULL, SCM_FALSE, NULL, 0)

/* class.c */
BINIT(SCM_CLASS_CLASS, "<class>", class_slots);
Expand Down
Loading

0 comments on commit 1257330

Please sign in to comment.