cgit.sxemacs.org Git - sxemacs/blob - src/dynacat.c

   1 /*** dynacat.c -- dynamic categories (`types' on top of types) for SXEmacs
   2  *
   3  * Copyright (C) 2005-2008 Sebastian Freundt <hroptatyr@sxemacs.org>
   4  *
   5  *
   6  * This file is part of SXEmacs.
   7  *
   8  * Redistribution and use in source and binary forms, with or without
   9  * modification, are permitted provided that the following conditions
  10  * are met:
  11  *
  12  * 1. Redistributions of source code must retain the above copyright
  13  *    notice, this list of conditions and the following disclaimer.
  14  *
  15  * 2. Redistributions in binary form must reproduce the above copyright
  16  *    notice, this list of conditions and the following disclaimer in the
  17  *    documentation and/or other materials provided with the distribution.
  18  *
  19  * 3. Neither the name of the author nor the names of any contributors
  20  *    may be used to endorse or promote products derived from this
  21  *    software without specific prior written permission.
  22  *
  23  * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
  24  * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  25  * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  26  * DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  27  * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  28  * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  29  * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
  30  * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  31  * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
  32  * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
  33  * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  34  *
  35  * Alternatively, for testing purposes, this file can be redistributed under
  36  * the following licence:
  37  * You can do whatever the fuck you want with this, except stop anyone else
  38  * doing whatever the fuck they want.
  39  *
  40  **/
  41
  42 #include "config.h"
  43 #include "lisp.h"
  44 #include "dynacat.h"
  45
  46 #define __DYNACAT_DEBUG__(args...)      fprintf(stderr, "DYNACAT " args)
  47 #ifndef DYNACAT_DEBUG_FLAG
  48 #define DYNACAT_DEBUG(args...)
  49 #else
  50 #define DYNACAT_DEBUG(args...)          __DYNACAT_DEBUG__(args)
  51 #endif
  52
  53 Lisp_Object Qdynacatp, Qdynacat;
  54
  55 static Lisp_Object
  56 mark_dynacat(Lisp_Object obj)
  57 {
  58         dynacat_t emp = XDYNACAT(obj);
  59         mark_object(emp->type);
  60         mark_object(emp->plist);
  61
  62         if (emp->mrkfun)
  63                 emp->mrkfun(obj);
  64
  65         return (emp->plist);
  66 }
  67
  68 static void
  69 print_dynacat(Lisp_Object obj, Lisp_Object printcharfun, int escapeflag)
  70 {
  71         /* This function can GC */
  72         dynacat_t emp = XDYNACAT(obj);
  73
  74         if (emp->prfun) {
  75                 emp->prfun(obj, printcharfun, escapeflag);
  76                 return;
  77         }
  78
  79         write_c_string("#<dynacat object", printcharfun);
  80         if (!NILP(emp->type)) {
  81                 write_c_string(" :type ", printcharfun);
  82                 print_internal(emp->type, printcharfun, escapeflag);
  83         }
  84         write_c_string(">", printcharfun);
  85 }
  86
  87 static void
  88 finalise_dynacat(void *unused, int for_disksave)
  89 {
  90         if (for_disksave) {
  91                 signal_simple_error(
  92                         "Can't dump an emacs containing "
  93                         "dynacat objects", Qt);
  94         }
  95 }
  96
  97 void
  98 dynacat_fini(dynacat_t emp)
  99 {
 100         DYNACAT_DEBUG(stderr, "#emdptr:0x%016lx@0x%016lx will pass away\n",
 101                       (long unsigned int)emp->ptr, (long unsigned int)emp);
 102         if (emp->finfun)
 103                 emp->finfun(wrap_object(emp), 0);
 104         else if (emp->ptr)
 105                 xfree(emp->ptr);
 106
 107         emp->prfun = NULL;
 108         emp->finfun = NULL;
 109         emp->mrkfun = NULL;
 110         emp->ptr = NULL;
 111         emp->plist = Qnil;
 112         emp->type = Qnil;
 113 }
 114
 115 static Lisp_Object
 116 dynacat_getprop(Lisp_Object obj, Lisp_Object property)
 117 {
 118         return external_plist_get(&XDYNACAT_PLIST(obj), property, 0, ERROR_ME);
 119 }
 120
 121 static int
 122 dynacat_putprop(Lisp_Object obj, Lisp_Object property, Lisp_Object value)
 123 {
 124         external_plist_put(&XDYNACAT_PLIST(obj), property, value, 0, ERROR_ME);
 125         return 1;
 126 }
 127
 128 static int
 129 dynacat_remprop(Lisp_Object obj, Lisp_Object property)
 130 {
 131         return external_remprop(&XDYNACAT_PLIST(obj), property, 0, ERROR_ME);
 132 }
 133
 134 DEFUN("dynacat-plist", Fdynacat_plist, 1, 1, 0, /*
 135 Return the property list of DYNACAT.
 136 */
 137       (dynacat))
 138 {
 139         CHECK_DYNACAT(dynacat);
 140         return XDYNACAT_PLIST(dynacat);
 141 }
 142
 143 static const struct lrecord_description dynacat_description[] = {
 144         {XD_LISP_OBJECT, offsetof(struct dynacat_s, type)},
 145         {XD_LISP_OBJECT, offsetof(struct dynacat_s, plist)},
 146         {XD_OPAQUE_DATA_PTR, offsetof(struct dynacat_s, ptr)},
 147         {XD_OPAQUE_DATA_PTR, offsetof(struct dynacat_s, mrkfun)},
 148         {XD_OPAQUE_DATA_PTR, offsetof(struct dynacat_s, finfun)},
 149         {XD_OPAQUE_DATA_PTR, offsetof(struct dynacat_s, prfun)},
 150         {XD_OPAQUE_DATA_PTR, offsetof(struct dynacat_s, intprfun)},
 151         {XD_END}
 152 };
 153
 154 DEFINE_BASIC_LRECORD_IMPLEMENTATION_WITH_PROPS(
 155         "dynacat", dynacat,
 156         mark_dynacat, print_dynacat, finalise_dynacat,
 157         NULL, NULL,
 158         dynacat_description,
 159         dynacat_getprop, dynacat_putprop, dynacat_remprop, Fdynacat_plist,
 160         struct dynacat_s);
 161
 162 #if 0
 163 inline static dynacat_t
 164 allocate_dynacat(void)
 165 {
 166         dynacat_t emp = alloc_lcrecord_type(struct dynacat_s, &lrecord_dynacat);
 167         return emp;
 168 }
 169
 170 Lisp_Object
 171 make_dynacat(void *ptr)
 172 {
 173         dynacat_t emp = allocate_dynacat();
 174         Lisp_Object result;
 175
 176         emp->prfun = NULL;
 177         emp->intprfun = NULL;
 178         emp->finfun = NULL;
 179         emp->mrkfun = NULL;
 180         emp->ptr = ptr;
 181         emp->type = Qnil;
 182         emp->plist = Qnil;
 183
 184         XSETDYNACAT(result, emp);
 185         return result;
 186 }
 187 #endif
 188
 189 \f
 190 DEFUN("dynacatp", Fdynacatp, 1, 1, 0, /*
 191 Return non-nil if OBJECT is an opaque emodule pointer.
 192 */
 193       (object))
 194 {
 195         if (DYNACATP(object))
 196                 return Qt;
 197         else
 198                 return Qnil;
 199 }
 200
 201 \f
 202 void syms_of_dynacat(void)
 203 {
 204         INIT_LRECORD_IMPLEMENTATION(dynacat);
 205
 206         DEFSYMBOL(Qdynacatp);
 207         DEFSYMBOL(Qdynacat);
 208
 209         DEFSUBR(Fdynacatp);
 210         DEFSUBR(Fdynacat_plist);
 211 }
 212
 213 void reinit_vars_of_dynacat(void)
 214 {
 215 }
 216
 217 void vars_of_dynacat(void)
 218 {
 219         reinit_vars_of_dynacat();
 220         Fprovide(intern("dynacat"));
 221 }
 222
 223 /* dynacat.c ends here */