1 /* clos.h -*- coding: utf-8; -*- 2 * 3 * Copyright (c) 2010-2021 Takashi Kato <ktakashi@ymail.com> 4 * 5 * Redistribution and use in source and binary forms, with or without 6 * modification, are permitted provided that the following conditions 7 * are met: 8 * 9 * 1. Redistributions of source code must retain the above copyright 10 * notice, this list of conditions and the following disclaimer. 11 * 12 * 2. Redistributions in binary form must reproduce the above copyright 13 * notice, this list of conditions and the following disclaimer in the 14 * documentation and/or other materials provided with the distribution. 15 * 16 * THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 17 * "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 18 * LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 19 * A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 20 * OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 21 * SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED 22 * TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR 23 * PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF 24 * LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING 25 * NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS 26 * SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 27 * 28 * $Id: $ 29 */ 30 #ifndef SAGITTARIUS_PRIVATE_CLOS_H_ 31 #define SAGITTARIUS_PRIVATE_CLOS_H_ 32 33 #include "sagittariusdefs.h" 34 #include "thread.h" 35 36 struct SgInstanceRec 37 { 38 SgByte *tag; 39 SgObject *slots; 40 }; 41 #define SG_INSTANCE(obj) ((SgInstance*)(obj)) 42 43 #define SG_INSTANCE_HEADER SgInstance hdr 44 45 /* accessor */ 46 SG_CLASS_DECL(Sg_SlotAccessorClass) 47 #define SG_CLASS_SLOT_ACCESSOR (&Sg_SlotAccessorClass) 48 typedef struct SgSlotAccessorRec SgSlotAccessor; 49 typedef SgObject (*SgSlotGetterProc)(SgObject); 50 typedef void (*SgSlotSetterProc)(SgObject, SgObject); 51 struct SgSlotAccessorRec 52 { 53 SG_HEADER; 54 int index; /* index */ 55 const char *cname; /* for static initilization */ 56 SgObject name; /* field name */ 57 SgClass *klass; /* slot class */ 58 SgSlotGetterProc getter; /* C getter */ 59 SgSlotSetterProc setter; /* C setter */ 60 /* No bound? for c proc */ 61 SgObject getterS; 62 SgObject setterS; 63 SgObject boundP; 64 SgObject definition; /* slot definition for book keeping */ 65 }; 66 #define SG_SLOT_ACCESSOR(obj) ((SgSlotAccessor*)(obj)) 67 #define SG_SLOT_ACCESSORP(obj) SG_XTYPEP(obj, SG_CLASS_SLOT_ACCESSOR) 68 69 #define SG_CLASS_SLOT_SPEC(name, index, getter, setter) \ 70 { { SG_CLASS2TAG(SG_CLASS_SLOT_ACCESSOR) }, \ 71 (index), (name), SG_FALSE, NULL, \ 72 (SgSlotGetterProc)(getter), \ 73 (SgSlotSetterProc)(setter), \ 74 SG_FALSE, SG_FALSE, SG_FALSE, SG_NIL } 75 76 77 /* based on tiny clos. most of tricks are from Gauche */ 78 /* define cprocs */ 79 typedef void (*SgClassPrintProc)(SgObject obj, SgPort *port, 80 SgWriteContext *mode); 81 typedef int (*SgClassCompareProc)(SgObject x, SgObject y, int equalP); 82 /* for external representation */ 83 typedef int (*SgClassSerializeProc)(SgObject obj, SgPort *port, 84 SgObject context); 85 typedef SgObject (*SgClassAllocateProc)(SgClass *klass, SgObject initargs); 86 /* For future use, define read/write own object cache */ 87 typedef SgObject (*SgReadCacheProc)(SgPort *port, void *ctx); 88 typedef SgObject (*SgWriteCacheScanProc)(SgObject obj, SgObject cbs, void *ctx); 89 typedef void (*SgWriteCacheProc)(SgObject obj, SgPort *port, void *ctx); 90 91 struct SgClassRec 92 { 93 union { 94 SG_INSTANCE_HEADER; 95 double align_dummy; 96 } classHdr; 97 98 SgClassPrintProc printer; 99 SgClassCompareProc compare; 100 SgClassSerializeProc serialize; 101 SgClassAllocateProc allocate; 102 /* cache procs */ 103 SgReadCacheProc cacheReader; 104 SgWriteCacheScanProc cacheScanner; 105 SgWriteCacheProc cacheWriter; 106 107 SgClass **cpa; 108 int nfields; /* need this? */ 109 int coreSize; 110 int flags; 111 112 /* scheme info */ 113 SgObject name; /* class name (scheme) */ 114 SgObject directSupers; /* list of classes */ 115 SgObject cpl; /* list of classes */ 116 SgObject directSlots; /* alist of name and definition */ 117 SgObject slots; /* alist of name and definition */ 118 SgObject directSubclasses; /* list of subclasses */ 119 SgSlotAccessor **gettersNSetters; /* array of accessors, NULL terminated */ 120 121 /* scheme cache */ 122 SgObject creader; 123 SgObject cscanner; 124 SgObject cwriter; 125 SgObject redefined; /* for change-class */ 126 SgObject library; /* defined library */ 127 SgObject initargs; /* for book keeping */ 128 /* For R6R integration */ 129 SgObject rtd; 130 SgObject rcd; 131 /* mutex */ 132 SgInternalMutex mutex; 133 SgInternalCond cv; 134 }; 135 136 #define SG_ISA(obj, clazz) (SG_XTYPEP(obj, clazz)||Sg_TypeP(SG_OBJ(obj), clazz)) 137 138 #define SG_CLASS(obj) ((SgClass*)(obj)) 139 #define SG_CLASSP(obj) SG_ISA(obj, SG_CLASS_CLASS) 140 141 #define SG_CLASS_FLAGS(obj) (SG_CLASS(obj)->flags) 142 #define SG_CLASS_CATEGORY(obj) (SG_CLASS_FLAGS(obj) & 3) 143 144 #define SG_CLASS_APPLICABLE_P(obj) (SG_CLASS_FLAGS(obj)&SG_CLASS_APPLICABLE) 145 146 #define SG_ALLOCATE(klassname, klass) \ 147 ((klassname*)Sg_AllocateInstance(klass)) 148 149 enum { 150 SG_CLASS_BUILTIN = 0, 151 SG_CLASS_ABSTRACT = 1, 152 SG_CLASS_BASE = 2, 153 SG_CLASS_SCHEME = 3, 154 /* A special flag that only be used for "native applicable" objects, 155 which basically inherits SgProcedure. */ 156 SG_CLASS_APPLICABLE = 0x04, 157 }; 158 159 /* built-in classes */ 160 SG_CLASS_DECL(Sg_TopClass); 161 SG_CLASS_DECL(Sg_BoolClass); 162 SG_CLASS_DECL(Sg_CharClass); 163 SG_CLASS_DECL(Sg_ClassClass); 164 SG_CLASS_DECL(Sg_EOFObjectClass); 165 SG_CLASS_DECL(Sg_UndefinedClass); 166 SG_CLASS_DECL(Sg_UnknownClass); 167 SG_CLASS_DECL(Sg_ObjectClass); /* base of Scheme-defined objects */ 168 169 #define SG_CLASS_TOP (&Sg_TopClass) 170 #define SG_CLASS_BOOL (&Sg_BoolClass) 171 #define SG_CLASS_CHAR (&Sg_CharClass) 172 #define SG_CLASS_CLASS (&Sg_ClassClass) 173 #define SG_CLASS_EOF_OBJECT (&Sg_EOFObjectClass) 174 #define SG_CLASS_UNDEFINED_OBJECT (&Sg_UndefinedClass) 175 #define SG_CLASS_UNKNOWN (&Sg_UnknownClass) 176 #define SG_CLASS_OBJECT (&Sg_ObjectClass) 177 178 extern SgClass *Sg_DefaultCPL[]; 179 extern SgClass *Sg_ObjectCPL[]; 180 181 #define SG_CLASS_DEFAULT_CPL (Sg_DefaultCPL) 182 #define SG_CLASS_OBJECT_CPL (Sg_ObjectCPL) 183 184 #define SG_DEFINE_CLASS_FULL(cname, coreSize, flag, reader, scanner, writer, printer, compare, serialize, allocate, cpa) \ 185 SgClass CLASS_KEYWORD cname = { \ 186 {{ SG_CLASS_STATIC_TAG(Sg_ClassClass), NULL }}, \ 187 printer, \ 188 compare, \ 189 serialize, \ 190 allocate, \ 191 (SgReadCacheProc )reader, \ 192 (SgWriteCacheScanProc)scanner, \ 193 (SgWriteCacheProc )writer, \ 194 cpa, \ 195 0, /* nfields */ \ 196 coreSize, /* coreSize */ \ 197 flag, /* flag */ \ 198 SG_FALSE, /* name */ \ 199 SG_NIL, /* directSupers */ \ 200 SG_NIL, /* cpl */ \ 201 SG_NIL, /* directSlots */ \ 202 SG_NIL, /* slots */ \ 203 SG_NIL, /* fieldInitializers */ \ 204 NULL, /* gettersNSetters */ \ 205 SG_FALSE, /* creader */ \ 206 SG_FALSE, /* cscanner */ \ 207 SG_FALSE, /* cwriter */ \ 208 SG_FALSE, /* redefined */ \ 209 SG_FALSE, /* library */ \ 210 SG_NIL, /* initargs */ \ 211 } 212 213 #define SG_DEFINE_CLASS_COMMON(cname, coreSize, flag, printer, compare, serialize, allocate, cpa) \ 214 SG_DEFINE_CLASS_FULL(cname, coreSize, flag, NULL, NULL, NULL, \ 215 printer, compare, serialize, allocate, cpa) 216 217 #define SG_DEFINE_BUILTIN_CLASS_WITH_CACHE(cname, reader, cacher, writer, printer, compare, serialize, allocate, cpa) \ 218 SG_DEFINE_CLASS_FULL(cname, 0, SG_CLASS_BUILTIN, reader, cacher, writer, \ 219 printer, compare, serialize, allocate, cpa) 220 #define SG_DEFINE_BUILTIN_CLASS_SIMPLE_WITH_CACHE(cname, reader, cacher, writer, printer) \ 221 SG_DEFINE_CLASS_FULL(cname, 0, SG_CLASS_BUILTIN, reader, cacher, writer, \ 222 printer, NULL, NULL, NULL, NULL) 223 224 #define SG_DEFINE_BUILTIN_CLASS(cname, printer, compare, serialize, allocate, cpa) \ 225 SG_DEFINE_CLASS_COMMON(cname, 0, SG_CLASS_BUILTIN, \ 226 printer, compare, serialize, allocate, cpa) 227 #define SG_DEFINE_BUILTIN_CLASS_SIMPLE(cname, printer) \ 228 SG_DEFINE_CLASS_COMMON(cname, 0, SG_CLASS_BUILTIN, \ 229 printer, NULL, NULL, NULL, NULL) 230 231 #define SG_DEFINE_ABSTRACT_CLASS(cname, cpa) \ 232 SG_DEFINE_CLASS_COMMON(cname, 0, SG_CLASS_ABSTRACT, \ 233 NULL, NULL, NULL, NULL, cpa) 234 235 #define SG_DEFINE_BASE_CLASS(cname, ctype, printer, compare, serialize, allocate, cpa) \ 236 SG_DEFINE_CLASS_COMMON(cname, sizeof(ctype), SG_CLASS_BASE, \ 237 printer, compare, serialize, allocate, cpa) 238 239 SG_CDECL_BEGIN 240 241 /* for Scheme world */ 242 SG_EXTERN SgObject Sg_VMSlotRef(SgObject obj, SgObject name); 243 SG_EXTERN SgObject Sg_VMSlotSet(SgObject obj, SgObject name, SgObject value); 244 SG_EXTERN SgObject Sg_VMSlotBoundP(SgObject obj, SgObject name); 245 /* for MOP */ 246 SG_EXTERN SgObject Sg_SlotRefUsingAccessor(SgObject obj, SgSlotAccessor *ac); 247 SG_EXTERN int Sg_SlotBoundUsingAccessor(SgObject obj, SgSlotAccessor *ac); 248 SG_EXTERN void Sg_SlotSetUsingAccessor(SgObject obj, SgSlotAccessor *ac, 249 SgObject value); 250 SG_EXTERN SgObject Sg_SlotRefUsingClass(SgClass *klass, SgObject obj, 251 SgObject name); 252 SG_EXTERN void Sg_SlotSetUsingClass(SgClass *klass, SgObject obj, 253 SgObject name, SgObject value); 254 SG_EXTERN int Sg_SlotBoundUsingClass(SgClass *klass, SgObject obj, 255 SgObject name); 256 /* MOP looks like APIs */ 257 SG_EXTERN SgClass* Sg_ClassOf(SgObject obj); 258 SG_EXTERN SgObject Sg_VMClassOf(SgObject obj); 259 SG_EXTERN SgObject Sg_VMIsA(SgObject obj, SgClass *klass); 260 /* type check */ 261 SG_EXTERN int Sg_TypeP(SgObject obj, SgClass *type); 262 SG_EXTERN int Sg_SubtypeP(SgClass *sub, SgClass *type); 263 264 /* To mimic with-world-lock and wrapper class in PCL */ 265 SG_EXTERN void Sg_StartClassRedefinition(SgClass *klass); 266 SG_EXTERN void Sg_EndClassRedefinition(SgClass *klass, SgObject newklass); 267 SG_EXTERN void Sg_ReplaceClassBinding(SgClass *oldklass, SgClass *newklass); 268 269 /* just access to SgClass */ 270 #define SG_CLASS_DIRECT_SUPERS(klass) (SG_CLASS(klass)->directSupers) 271 #define SG_CLASS_DIRECT_SLOTS(klass) (SG_CLASS(klass)->directSlots) 272 #define SG_CLASS_CPL(klass) (SG_CLASS(klass)->cpl) 273 /* for C use */ 274 #define SG_CLASS_CPA(klass) (SG_CLASS(klass)->cpa) 275 #define SG_CLASS_SLOTS(klass) (SG_CLASS(klass)->slots) 276 277 /* intercessory protocol */ 278 SG_EXTERN SgObject Sg_AllocateInstance(SgClass *klass); 279 SG_EXTERN SgObject Sg_ComputeCPL(SgClass *klass); 280 SG_EXTERN SgObject Sg_ComputeSlots(SgClass *klass); 281 SG_EXTERN SgObject Sg_ComputeGetterAndSetter(SgClass *klass, SgObject slot); 282 SG_EXTERN SgObject Sg_MakeSlotAccessor(SgClass *klass, SgObject slot, 283 int index, 284 SgObject getter, SgObject setter, 285 SgObject boundP); 286 287 SG_EXTERN int Sg_ApplicableP(SgObject spec, SgObject args); 288 289 /* builtin class <object> */ 290 SG_EXTERN SgObject Sg_ObjectAllocate(SgClass *klass, SgObject initargs); 291 292 /* MOP util */ 293 SG_EXTERN void Sg_AddDirectSubclass(SgClass *super, SgClass *sub); 294 SG_EXTERN void Sg_RemoveDirectSubclass(SgClass *super, SgClass *sub); 295 296 /* internal for C. */ 297 SG_EXTERN void Sg_InitStaticClass(SgClass *klass, const SgChar *name, 298 SgLibrary *lib, SgSlotAccessor *specs, 299 int flags); 300 SG_EXTERN void Sg_InitStaticClassWithMeta(SgClass *klass, 301 const SgChar *name, 302 SgLibrary *lib, SgClass *meta, 303 SgObject supers, 304 SgSlotAccessor *specs, int flags); 305 306 SG_EXTERN SgObject Sg_VMSlotInitializeUsingAccessor(SgObject obj, SgObject acc, 307 SgObject initargs); 308 SG_EXTERN SgObject Sg_VMSlotRefUsingSlotDefinition(SgObject obj, 309 SgObject slot); 310 SG_EXTERN SgObject Sg_VMSlotSetUsingSlotDefinition(SgObject obj, 311 SgObject slot, 312 SgObject value); 313 SG_EXTERN SgObject Sg_VMSlotBoundUsingSlotDefinition(SgObject obj, 314 SgObject slot); 315 316 SG_EXTERN SgClass* Sg_BaseClassOf(SgClass *klass); 317 318 SG_EXTERN void Sg_SwapClassAndSlots(SgObject newInstance, 319 SgObject oldInstance); 320 321 /* compare */ 322 SG_EXTERN int Sg_ObjectCompare(SgObject x, SgObject y); 323 324 SG_CDECL_END 325 326 #endif /* SAGITTARIUS_CLOS_H_ */ 327