1 /* subr.h -*- mode:c; 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_SUBR_H_ 31 #define SAGITTARIUS_PRIVATE_SUBR_H_ 32 33 #include "sagittariusdefs.h" 34 #include "clos.h" 35 36 typedef SgObject SgSubrProc(SgObject *args, int argc, void *user_data); 37 38 SG_CLASS_DECL(Sg_ProcedureClass); 39 #define SG_CLASS_PROCEDURE (&Sg_ProcedureClass) 40 typedef enum { 41 SG_PROC_SUBR, 42 SG_PROC_CLOSURE, 43 SG_PROC_GENERIC, 44 SG_PROC_METHOD, 45 SG_PROC_NEXT_METHOD, 46 } SgProcedureType; 47 48 /* bit tricky... */ 49 enum { 50 SG_CLOSURE_UNCHECKED = 0, 51 SG_SUBR_SIDE_EFFECT = 0, /* not transparent nor no side effect */ 52 /* blow 2 are common for subr and closure */ 53 SG_PROC_TRANSPARENT = 0x01, /* 0b01 */ 54 SG_PROC_NO_SIDE_EFFECT = 0x02, /* 0b10 */ 55 /* below is only for closuers */ 56 SG_CLOSURE_SIDE_EFFECT = 0x03, /* 0b11 */ 57 /* error */ 58 SG_PROC_ERROR = 0x04 /* 0b0100 */ 59 }; 60 #define SG_PROC_EFFECT_MASK 0x03 61 #define SG_PROC_ERROR_MASK 0x0C 62 63 #define SG_PROC_EFFECT_FLAG_EQ(f, name) ((f&SG_PROC_EFFECT_MASK)==name) 64 #define SG_PROC_ERROR_FLAGP(f) ((f&SG_PROC_ERROR_MASK)==SG_PROC_ERROR) 65 66 struct SgProcedureRec 67 { 68 SG_INSTANCE_HEADER; 69 unsigned int required : 16; /* # of required arguments */ 70 unsigned int optional : 8; /* # of optional arguments. 71 for subr optimisation. to check this number 72 then we don't have to pack the argument to 73 a list. 74 for closure, this can be either 0 or 1 75 for now. */ 76 unsigned int type : 3; /* procedure type defined above */ 77 unsigned int locked : 1; /* setter locked? */ 78 unsigned int transparent: 4; /* transparent flags; 79 4 bits with following structure 80 ee bb 81 bb: 82 00: subr FALSE, closuer UNCHECKED 83 01: transparent 84 10: no side effect 85 11: only closure FALSE 86 ee: 87 00: not an error procedure 88 01: error procedure 89 */ 90 /* unsigned int reserved : 24; */ 91 SgObject name; /* procedure name */ 92 SgObject setter; /* setter procedure of this procedure. */ 93 SgObject inliner; /* #f, procedure or instruction */ 94 }; 95 96 #define SG_PROCEDURE(obj) ((SgProcedure*)(obj)) 97 #define SG_PROCEDUREP(obj) \ 98 (SG_HOBJP(obj)&&SG_CLASS_APPLICABLE_P(SG_CLASS_OF(obj))) 99 #define SG_PROCEDURE_REQUIRED(obj) SG_PROCEDURE(obj)->required 100 #define SG_PROCEDURE_OPTIONAL(obj) SG_PROCEDURE(obj)->optional 101 #define SG_PROCEDURE_TYPE(obj) SG_PROCEDURE(obj)->type 102 #define SG_PROCEDURE_TRANSPARENT(obj) SG_PROCEDURE(obj)->transparent 103 #define SG_PROCEDURE_NAME(obj) SG_PROCEDURE(obj)->name 104 #define SG_PROCEDURE_INLINER(obj) SG_PROCEDURE(obj)->inliner 105 #define SG_PROCEDURE_SETTER(obj) SG_PROCEDURE(obj)->setter 106 107 #define SG_PROCEDURE_TRANSPARENTP(obj) \ 108 SG_PROC_EFFECT_FLAG_EQ(SG_PROCEDURE(obj)->transparent, SG_PROC_TRANSPARENT) 109 #define SG_PROCEDURE_NO_SIDE_EFFECTP(obj) \ 110 SG_PROC_EFFECT_FLAG_EQ(SG_PROCEDURE(obj)->transparent, SG_PROC_NO_SIDE_EFFECT) 111 #define SG_PROCEDURE_ERRORP(obj) \ 112 SG_PROC_ERROR_FLAGP(SG_PROCEDURE(obj)->transparent) 113 114 #define SG_PROCEDURE_INIT(obj, req, opt, typ, name) \ 115 SG_PROCEDURE_REQUIRED(obj) = (req), \ 116 SG_PROCEDURE_OPTIONAL(obj) = (opt), \ 117 SG_PROCEDURE_TYPE(obj) = (typ), \ 118 SG_PROCEDURE_TRANSPARENT(obj) = FALSE, \ 119 SG_PROCEDURE_NAME(obj) = (name), \ 120 SG_PROCEDURE(obj)->locked = FALSE, \ 121 SG_PROCEDURE_INLINER(obj) = SG_FALSE, \ 122 SG_PROCEDURE_SETTER(obj) = SG_FALSE 123 124 #define SG__PROCEDURE_INITIALIZER(klass, req, opt, type, name, inliner) \ 125 { {(klass)},(req),(opt),(type),FALSE, 0, (name), SG_FALSE, (inliner) } 126 127 /* This is just container for procedure */ 128 struct SgSubrRec 129 { 130 SgProcedure common; 131 SgSubrProc *func; 132 void *data; 133 }; 134 135 #define SG_SUBR(obj) ((SgSubr*)(obj)) 136 #define SG_SUBRP(obj) \ 137 (SG_PROCEDUREP(obj) && SG_PROCEDURE_TYPE(obj) == SG_PROC_SUBR) 138 #define SG_SUBR_FUNC(obj) (SG_SUBR(obj)->func) 139 #define SG_SUBR_DATA(obj) (SG_SUBR(obj)->data) 140 141 #define SG__DEFINE_SUBR_INT(cvar, req, opt, func, inliner, data) \ 142 SgSubr cvar = { \ 143 SG__PROCEDURE_INITIALIZER(SG_CLASS_STATIC_TAG(Sg_ProcedureClass), \ 144 req, opt, SG_PROC_SUBR, \ 145 SG_FALSE, inliner), \ 146 (func), (data) \ 147 } 148 149 #define SG_DEFINE_SUBR(cvar, req, opt, func, inliner, data) \ 150 SG__DEFINE_SUBR_INT(cvar, req, opt, func, inliner, data) 151 152 #define SG_ENTER_SUBR(name) 153 #define SG_ARGREF(count) (SG_FP[count]) 154 #define SG_RETURN(value) return value 155 156 #define SG_MAYBE_P(pred, obj) (SG_FALSEP(obj)||(pred(obj))) 157 #define SG_MAYBE(unboxer, obj) (SG_FALSEP(obj)?NULL:(unboxer(obj))) 158 #define SG_MAKE_MAYBE(boxer, obj) ((obj)?(boxer(obj)):SG_FALSE) 159 160 /* Calling subr directly. 161 162 Calling Scheme procedure using Sg_Apply is expensive and may impact 163 performance. For example, generic hashtable uses Scheme procedures 164 however calling this with Sg_Apply is slow. To make performance a bit 165 better, we call subr without using Sg_Apply. 166 There are couple of edge case to do it; 167 168 - optional argument handling 169 - continuation passing style 170 171 #1: If the subr accepts optional arguments then it must be provided 172 even if it's not there. For now, we don't allow calling following 173 type of situation: 174 required argument: 1 175 optional argument: n 176 call with 2 arguments 177 Handling above situation is requires the same thing as vmcall.c 178 does. 179 #2: If the subr calls Sg_VMApply or Sg_VMPushCC inside, this would 180 most likely fails. However we don't (or rather can't) check it. 181 So this must be users' responsibility. 182 */ 183 #define SG_CALL_SUBR_n(r, subr, n, ...) \ 184 do { \ 185 SgObject args__[n+1] = {__VA_ARGS__, SG_NIL}; \ 186 int argc__ = (n); \ 187 if (SG_PROCEDURE_OPTIONAL(subr)) argc__++; \ 188 (r) = SG_SUBR_FUNC(subr)(args__, argc__, SG_SUBR_DATA(subr)); \ 189 } while (0) 190 #define SG_CALL_SUBR1(r, subr, arg) SG_CALL_SUBR_n(r, subr, 1, arg) 191 #define SG_CALL_SUBR2(r, subr, arg1, arg2) \ 192 SG_CALL_SUBR_n(r, subr, 2, arg1, arg2) 193 194 195 196 SG_CDECL_BEGIN 197 198 SG_EXTERN SgObject Sg_MakeSubr(SgSubrProc proc, void *data, int required, 199 int optional, SgObject info); 200 SG_EXTERN SgObject Sg_MakeSubrFull(SgSubrProc proc, void *data, int required, 201 int optional, SgObject info, int trans); 202 SG_EXTERN SgObject Sg_NullProc(); 203 SG_EXTERN SgObject Sg_SetterSet(SgProcedure *proc, SgProcedure *setter, 204 int lock); 205 SG_EXTERN SgObject Sg_Setter(SgObject proc); 206 SG_EXTERN int Sg_HasSetter(SgObject proc); 207 208 SG_CDECL_END 209 210 #endif /* SAGITTARIUS_SUBR_H_ */ 211 212 /* 213 end of file 214 Local Variables: 215 coding: utf-8-unix 216 End: 217 */ 218