1 /* generic.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_GENERIC_H_ 31 #define SAGITTARIUS_PRIVATE_GENERIC_H_ 32 33 #include "sagittariusdefs.h" 34 #include "thread.h" 35 #include "subr.h" 36 #include "clos.h" 37 38 /* generic */ 39 SG_CLASS_DECL(Sg_GenericClass); 40 #define SG_CLASS_GENERIC (&Sg_GenericClass) 41 42 typedef struct SgGenericRec SgGeneric; 43 struct SgGenericRec 44 { 45 SgProcedure common; 46 SgObject methods; /* list of applicable procedures */ 47 int maxReqargs; 48 /* generic defined in C can have C function for the very last method */ 49 SgObject (*fallback)(SgObject *argv, int argc, SgGeneric *gf); 50 void *data; 51 SgInternalMutex mutex; 52 }; 53 #define SG_GENERIC(obj) ((SgGeneric*)(obj)) 54 #define SG_GENERICP(obj) SG_XTYPEP(obj, SG_CLASS_GENERIC) 55 #define SG_GENERIC_METHODS(generic) (SG_GENERIC(generic)->methods) 56 #define SG_GENERIC_FALLBACK(generic) (SG_GENERIC(generic)->fallback) 57 #define SG_GENERIC_DATA(generic) (SG_GENERIC(generic)->data) 58 #define SG_GENERIC_MAX_REQARGS(generic) (SG_GENERIC(generic)->maxReqargs) 59 #define SG_GENERIC_MUTEX(generic) (&(SG_GENERIC(generic)->mutex)) 60 61 #define SG_DEFINE_GENERIC(cvar, cfunc, data) \ 62 SgGeneric cvar = { \ 63 SG__PROCEDURE_INITIALIZER(SG_CLASS_STATIC_TAG(Sg_GenericClass), \ 64 0, 0, SG_PROC_GENERIC, \ 65 SG_FALSE, SG_FALSE), \ 66 SG_NIL, 0, (cfunc), data \ 67 } 68 69 /* method */ 70 SG_CLASS_DECL(Sg_MethodClass); 71 #define SG_CLASS_METHOD (&Sg_MethodClass) 72 73 typedef struct SgMethodRec 74 { 75 SgProcedure common; 76 SgGeneric *generic; 77 SgKeyword *qualifier; /* :primary :around :before or :after */ 78 SgClass **specializers; /* list of class. 79 must be array to initialize statically. */ 80 SgObject procedure; /* subr or closuer. 81 (lambda (call-next-method generic) ...) */ 82 int leafp; /* call-next-method is called or not */ 83 } SgMethod; 84 #define SG_METHOD(obj) ((SgMethod*)(obj)) 85 #define SG_METHODP(obj) SG_XTYPEP(obj, SG_CLASS_METHOD) 86 87 #define SG_METHOD_GENERIC(method) (SG_METHOD(method)->generic) 88 #define SG_METHOD_SPECIALIZERS(method) (SG_METHOD(method)->specializers) 89 #define SG_METHOD_PROCEDURE(method) (SG_METHOD(method)->procedure) 90 #define SG_METHOD_QUALIFIER(method) (SG_METHOD(method)->qualifier) 91 #define SG_METHOD_LEAF_P(method) (SG_METHOD(method)->leafp) 92 93 #define SG_DEFINE_METHOD(cvar, gf, req, opt, specs, proc) \ 94 SgMethod cvar = { \ 95 SG__PROCEDURE_INITIALIZER(SG_CLASS_STATIC_TAG(Sg_MethodClass), \ 96 req, opt, SG_PROC_METHOD, \ 97 SG_FALSE, SG_FALSE), \ 98 gf, SG_KEYWORD(SG_FALSE), specs, proc, 0 \ 99 } 100 101 SG_CLASS_DECL(Sg_NextMethodClass); 102 #define SG_CLASS_NEXT_METHOD (&Sg_NextMethodClass) 103 104 typedef struct SgNextMethodRec 105 { 106 SgProcedure common; 107 SgGeneric *generic; 108 SgObject methods; 109 SgObject *argv; 110 int argc; 111 } SgNextMethod; 112 #define SG_NEXT_METHOD(obj) ((SgNextMethod*)(obj)) 113 #define SG_NEXT_METHODP(obj) SG_XTYPEP(obj, SG_CLASS_NEXT_METHOD) 114 115 SG_CLASS_DECL(Sg_EqlSpecializerClass); 116 #define SG_CLASS_EQL_SPECIALIZER (&Sg_EqlSpecializerClass) 117 118 typedef struct SgEqlSpecializerRec 119 { 120 SG_HEADER; 121 SgObject object; 122 } SgEqlSpecializer; 123 124 #define SG_EQL_SPECIALIZER(obj) ((SgEqlSpecializer *)obj) 125 #define SG_EQL_SPECIALIZERP(obj) SG_XTYPEP(obj, SG_CLASS_EQL_SPECIALIZER) 126 127 SG_CDECL_BEGIN 128 129 SG_EXTERN SgObject Sg_MakeBaseGeneric(SgObject name, 130 SgObject (*fallback)(SgObject *, int, 131 SgGeneric *), 132 void *data); 133 134 SG_EXTERN void Sg_InitBuiltinGeneric(SgGeneric *gf, const SgChar *name, 135 SgLibrary *lib); 136 SG_EXTERN void Sg_InitBuiltinMethod(SgMethod *m); 137 SG_EXTERN SgObject Sg_NoNextMethod(SgObject *argv, int argc, SgGeneric *gf); 138 SG_EXTERN SgObject Sg_InvalidApply(SgObject *argv, int argc, SgGeneric *gf); 139 140 /* needs to be here ... */ 141 SG_EXTERN SgObject Sg_AddMethod(SgGeneric *generic, SgMethod *method); 142 SG_EXTERN SgObject Sg_RemoveMethod(SgGeneric *generic, SgMethod *method); 143 SG_EXTERN SgObject Sg_ComputeMethods(SgGeneric *gf, SgObject *argv, int argc, 144 int applyargs); 145 SG_EXTERN SgObject Sg_MakeNextMethod(SgGeneric *gf, SgObject methods, 146 SgObject *argv, int argc, int copyargs); 147 148 SG_EXTERN SgObject Sg_MakeEqlSpecializer(SgObject obj); 149 150 /* internal use */ 151 SG_EXTERN SgObject Sg_ComputeApplicableMethods(SgObject gf, SgObject args); 152 SG_EXTERN SgObject Sg_VMSortMethodByQualifier(SgObject methods); 153 SG_EXTERN SgObject Sg_VMComputeAroundMethods(SgObject around, SgObject before, 154 SgObject primary, SgObject after); 155 156 /* I'm not sure if these should be usable from other shared object. */ 157 /* The initialization protocol */ 158 SG_EXTERN SgGeneric Sg_GenericMake; 159 SG_EXTERN SgGeneric Sg_GenericInitialize; 160 /* the instance structure protocol */ 161 SG_EXTERN SgGeneric Sg_GenericAllocateInstance; 162 /* The class initialization protocol */ 163 SG_EXTERN SgGeneric Sg_GenericComputeCPL; 164 SG_EXTERN SgGeneric Sg_GenericComputeSlots; 165 SG_EXTERN SgGeneric Sg_GenericAddMethod; 166 SG_EXTERN SgGeneric Sg_GenericRemoveMethod; 167 168 SG_EXTERN SgGeneric Sg_GenericComputeGetterAndSetter; 169 170 /* The generic invocation protocol */ 171 SG_EXTERN SgGeneric Sg_GenericComputeApplyGeneric; 172 SG_EXTERN SgGeneric Sg_GenericComputeMethodMoreSpecificP; 173 SG_EXTERN SgGeneric Sg_GenericComputeApplyMethods; 174 175 SG_EXTERN SgGeneric Sg_GenericObjectEqualP; 176 SG_EXTERN SgGeneric Sg_GenericObjectApply; 177 SG_EXTERN SgGeneric Sg_GenericObjectSetter; 178 SG_EXTERN SgGeneric Sg_GenericObjectCompare; 179 SG_EXTERN SgGeneric Sg_GenericObjectHash; 180 181 /* slot stuff */ 182 SG_EXTERN SgGeneric Sg_GenericSlotUnbound; 183 SG_EXTERN SgGeneric Sg_GenericSlotMissing; 184 185 /* might be for debugger? */ 186 SG_EXTERN SgGeneric Sg_GenericUnboundVariable; 187 188 /* for mop */ 189 SG_EXTERN SgGeneric Sg_GenericChangeClass; 190 191 SG_CDECL_END 192 193 #endif /* SAGITTARIUS_GENERIC_H_ */ 194