cgit.sxemacs.org Git - sxemacs/blob - src/ent/ent-binary-op.h

   1 /*
   2   ent-binary-op.h -- Global Binary Operations
   3   Copyright (C) 2006, 2007, 2008 Sebastian Freundt
   4
   5   Author:  Sebastian Freundt <hroptatyr@sxemacs.org>
   6
   7   * This file is part of SXEmacs.
   8   *
   9   * Redistribution and use in source and binary forms, with or without
  10   * modification, are permitted provided that the following conditions
  11   * are met:
  12   *
  13   * 1. Redistributions of source code must retain the above copyright
  14   *    notice, this list of conditions and the following disclaimer.
  15   *
  16   * 2. Redistributions in binary form must reproduce the above copyright
  17   *    notice, this list of conditions and the following disclaimer in the
  18   *    documentation and/or other materials provided with the distribution.
  19   *
  20   * 3. Neither the name of the author nor the names of any contributors
  21   *    may be used to endorse or promote products derived from this
  22   *    software without specific prior written permission.
  23   *
  24   * THIS SOFTWARE IS PROVIDED BY THE AUTHOR "AS IS" AND ANY EXPRESS OR
  25   * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED
  26   * WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE
  27   * DISCLAIMED.  IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE
  28   * FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
  29   * CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
  30   * SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR
  31   * BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  32   * WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE
  33   * OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN
  34   * IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  35   */
  36
  37 /* Synched up with: Not in FSF. */
  38
  39 #ifndef INCLUDED_ent_binary_op_h_
  40 #define INCLUDED_ent_binary_op_h_
  41
  42 #include "ent-lift.h"
  43
  44 #define ENT_DEBUG_BINOP(args...)        ENT_DEBUG("[BINOP]: " args)
  45
  46 /*************************/
  47 /* new ASE optable magic */
  48 /*************************/
  49 /* the binary optable */
  50 typedef enum ase_binary_operation_e ase_binary_operation_t;
  51 typedef Lisp_Object(*ase_binary_operation_f)(Lisp_Object, Lisp_Object);
  52
  53 enum ase_binary_operation_e {
  54         ASE_BINARY_OP_SUM,
  55         ASE_BINARY_FIRST_OP = ASE_BINARY_OP_SUM,
  56         ASE_BINARY_OP_DIFF,
  57         ASE_BINARY_OP_PROD,
  58         ASE_BINARY_OP_DIV,
  59         ASE_BINARY_OP_QUO,
  60         ASE_BINARY_OP_REM,
  61         ASE_BINARY_OP_MOD,
  62         ASE_BINARY_OP_POW,
  63         ASE_BINARY_LAST_OP = ASE_BINARY_OP_POW,
  64         N_ASE_BINARY_OPS
  65 };
  66
  67 extern int common_lisp_slash;
  68 extern ase_binary_operation_f
  69 ase_binary_optable[N_ASE_BINARY_OPS][ASE_OPTABLE_SIZE][ASE_OPTABLE_SIZE];
  70
  71 extern Lisp_Object ase_binary_operation_undefined(Lisp_Object, Lisp_Object);
  72 extern_inline void
  73 ent_binop_register(
  74         ase_binary_operation_t op,
  75         ase_object_type_t t1, ase_object_type_t t2,
  76         ase_binary_operation_f opf);
  77 extern_inline void
  78 ent_binop_unregister(
  79         ase_binary_operation_t op,
  80         ase_object_type_t t1, ase_object_type_t t2);
  81 extern_inline Lisp_Object
  82 _ent_binop(
  83         ase_binary_operation_t op,
  84         ase_object_type_t l1t, Lisp_Object l1,
  85         ase_object_type_t l2t, Lisp_Object l2);
  86 extern_inline Lisp_Object
  87 ent_binop(ase_binary_operation_t op, Lisp_Object l1, Lisp_Object l2);
  88 extern_inline Lisp_Object
  89 ent_binop_many(ase_binary_operation_t op, int nargs, Lisp_Object *args);
  90
  91 \f
  92 extern_inline void
  93 ent_binop_register(ase_binary_operation_t op,
  94                    ase_object_type_t t1, ase_object_type_t t2,
  95                    ase_binary_operation_f opf)
  96 {
  97         ase_binary_optable[op][t1][t2] = opf;
  98         return;
  99 }
 100 extern_inline void
 101 ent_binop_unregister(ase_binary_operation_t op,
 102                      ase_object_type_t t1, ase_object_type_t t2)
 103 {
 104         ase_binary_optable[op][t1][t2] = ase_binary_operation_undefined;
 105         return;
 106 }
 107
 108 extern void ase_binary_optable_init(void);
 109
 110 extern_inline Lisp_Object
 111 _ent_binop(ase_binary_operation_t op,
 112            ase_object_type_t l1t, Lisp_Object l1,
 113            ase_object_type_t l2t, Lisp_Object l2)
 114 {
 115         ase_binary_operation_f opf =
 116                 ase_binary_optable[op][l1t][l2t];
 117
 118         return opf(l1, l2);
 119 }
 120
 121 extern_inline Lisp_Object
 122 ent_binop(ase_binary_operation_t op, Lisp_Object l1, Lisp_Object l2)
 123 {
 124         ase_object_type_t l1t = ase_optable_index(l1);
 125         ase_object_type_t l2t = ase_optable_index(l2);
 126
 127         return _ent_binop(op, l1t, l1, l2t, l2);
 128 }
 129
 130 extern_inline Lisp_Object
 131 ent_binop_many(ase_binary_operation_t op, int nargs, Lisp_Object *args)
 132 {
 133         REGISTER int i;
 134         Lisp_Object accum;
 135         ase_object_type_t _acct, addt;
 136
 137         for (accum = args[0], i = 1; i < nargs; i++) {
 138                 _acct = ase_optable_index(accum);
 139                 addt = ase_optable_index(args[i]);
 140                 accum = _ent_binop(op, _acct, accum, addt, args[i]);
 141         }
 142
 143         return accum;
 144 }
 145
 146 /* convenience funs (implement as macroes maybe?) */
 147 #if 0
 148 extern_inline Lisp_Object
 149 _ent_binop_sum(ase_object_type_t l1t, Lisp_Object l1,
 150                ase_object_type_t l2t, Lisp_Object l2);
 151 extern_inline Lisp_Object
 152 ent_binop_sum(Lisp_Object l1, Lisp_Object l2);
 153
 154 extern_inline void
 155 ent_binop_register_sum(ase_object_type_t t1, ase_object_type_t t2,
 156                        ase_binary_operation_f opf);
 157 extern_inline void
 158 ent_binop_unregister_sum(ase_object_type_t t1, ase_object_type_t t2,
 159                          ase_binary_operation_f opf);
 160 #endif
 161
 162 #if 0
 163 #define Fplus   Fent_binop_sum
 164 #define Fminus  Fent_binop_diff
 165 #define Ftimes  Fent_binop_prod
 166 #define Fdiv    Fent_binop_divX
 167 #define Fquo    Fent_binop_div
 168 #define Fquo2   Fent_binop_quo
 169 #define Frem    Fent_binop_rem
 170 #define Fmod    Fent_binop_mod
 171 #define Fpow    Fent_binop_pow
 172 #endif
 173 EXFUN(Fent_binop_sum, MANY);
 174 EXFUN(Fent_binop_diff, MANY);
 175 EXFUN(Fent_binop_prod, MANY);
 176 EXFUN(Fent_binop_div, MANY);
 177 EXFUN(Fent_binop_divX, MANY);
 178 EXFUN(Fent_binop_quo, MANY);
 179 EXFUN(Fent_binop_rem, 2);
 180 EXFUN(Fent_binop_mod, 2);
 181 EXFUN(Fent_binop_pow, 2);
 182
 183 extern void syms_of_ent_binary_op(void);
 184 extern void vars_of_ent_binary_op(void);
 185
 186 extern_inline Lisp_Object
 187 __ent_binop_lift_1(
 188         ase_binary_operation_t op,
 189         ase_object_type_t l1t, Lisp_Object l1,
 190         ase_object_type_t l2t, Lisp_Object l2,
 191         ent_lift_args_t la);
 192 extern_inline Lisp_Object
 193 _ent_binop_lift_1(
 194         ase_binary_operation_t op,
 195         Lisp_Object l1, ase_object_type_t l2t, Lisp_Object l2,
 196         ent_lift_args_t la);
 197 extern_inline Lisp_Object
 198 ent_binop_lift_1(
 199         ase_binary_operation_t op,
 200         Lisp_Object l1, Lisp_Object l2,
 201         ent_lift_args_t la);
 202 extern_inline Lisp_Object
 203 __ent_binop_lift_2(
 204         ase_binary_operation_t op,
 205         ase_object_type_t l1t, Lisp_Object l1,
 206         ase_object_type_t l2t, Lisp_Object l2,
 207         ent_lift_args_t la);
 208 extern_inline Lisp_Object
 209 _ent_binop_lift_2(
 210         ase_binary_operation_t op,
 211         ase_object_type_t l1t, Lisp_Object l1, Lisp_Object l2,
 212         ent_lift_args_t la);
 213 extern_inline Lisp_Object
 214 ent_binop_lift_2(
 215         ase_binary_operation_t op,
 216         Lisp_Object l1, Lisp_Object l2,
 217         ent_lift_args_t la);
 218
 219 \f
 220 /* lift to first or second arg and perform an operation */
 221 extern_inline Lisp_Object
 222 __ent_binop_lift_1(ase_binary_operation_t op,
 223                    ase_object_type_t l1t, Lisp_Object l1,
 224                    ase_object_type_t l2t, Lisp_Object l2,
 225                    ent_lift_args_t la)
 226 {
 227         Lisp_Object l1n = _ent_lift(l1t, l1, l2t, la);
 228         return _ent_binop(op, l2t, l1n, l2t, l2);
 229 }
 230
 231 extern_inline Lisp_Object
 232 _ent_binop_lift_1(ase_binary_operation_t op,
 233                   Lisp_Object l1, ase_object_type_t l2t, Lisp_Object l2,
 234                   ent_lift_args_t la)
 235 {
 236         /* lifts l1 to l2t and calls the native op */
 237         ase_object_type_t l1t = ase_optable_index(l1);
 238         return __ent_binop_lift_1(op, l1t, l1, l2t, l2, la);
 239 }
 240
 241 extern_inline Lisp_Object
 242 ent_binop_lift_1(ase_binary_operation_t op,
 243                  Lisp_Object l1, Lisp_Object l2,
 244                  ent_lift_args_t la)
 245 {
 246         /* lifts arg l1 to the world of l2 and calls the native op */
 247         ase_object_type_t l2t = ase_optable_index(l2);
 248         return _ent_binop_lift_1(op, l1, l2t, l2, la);
 249 }
 250
 251 extern_inline Lisp_Object
 252 __ent_binop_lift_2(ase_binary_operation_t op,
 253                    ase_object_type_t l1t, Lisp_Object l1,
 254                    ase_object_type_t l2t, Lisp_Object l2,
 255                    ent_lift_args_t la)
 256 {
 257         Lisp_Object l2n = _ent_lift(l2t, l2, l1t, la);
 258         return _ent_binop(op, l1t, l1, l1t, l2n);
 259 }
 260
 261 extern_inline Lisp_Object
 262 _ent_binop_lift_2(ase_binary_operation_t op,
 263                   ase_object_type_t l1t, Lisp_Object l1, Lisp_Object l2,
 264                   ent_lift_args_t la)
 265 {
 266         /* lifts l2 to l1t and calls the native op */
 267         ase_object_type_t l2t = ase_optable_index(l2);
 268         return __ent_binop_lift_2(op, l1t, l1, l2t, l2, la);
 269 }
 270
 271 extern_inline Lisp_Object
 272 ent_binop_lift_2(ase_binary_operation_t op,
 273                  Lisp_Object l1, Lisp_Object l2,
 274                  ent_lift_args_t la)
 275 {
 276         /* lifts arg l2 to the world of l1 and calls the native op */
 277         ase_object_type_t l1t = ase_optable_index(l1);
 278         return _ent_binop_lift_2(op, l1t, l1, l2, la);
 279 }
 280
 281 #endif  /* INCLUDED_ent_binary_op_h_ */