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

   1 /*
   2   ent-binary-op.c -- Global Binary Operations
   3   Copyright (C) 2006-2012 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 #include <config.h>
  40 #include "lisp.h"
  41 #include "ent-optable.h"
  42 #include "ent-binary-op.h"
  43 #include "ent-unary-op.h"
  44
  45 extern Lisp_Object Qoperation_error;
  46
  47 int common_lisp_slash;
  48 ase_binary_operation_f ase_binary_optable
  49 [N_ASE_BINARY_OPS][ASE_OPTABLE_SIZE][ASE_OPTABLE_SIZE];
  50
  51 \f
  52 Lisp_Object
  53 ase_binary_operation_undefined(Lisp_Object l, Lisp_Object r)
  54 {
  55         fprintf(stderr, "\n");
  56         print_internal(l, Qexternal_debugging_output, 0);
  57         fprintf(stderr, "  type:%d\n", ase_optable_index(l));
  58         print_internal(r, Qexternal_debugging_output, 0);
  59         fprintf(stderr, "  type:%d\n", ase_optable_index(r));
  60
  61         Fsignal(Qoperation_error, list2(l, r));
  62         return Qnil;
  63 }
  64
  65 static inline void
  66 _ase_binary_optable_init(ase_binary_operation_t op)
  67 {
  68         int i, j;
  69         for (i = 0; i < ASE_OPTABLE_SIZE; i++) {
  70                 for (j = 0; j < ASE_OPTABLE_SIZE; j++) {
  71                         ent_binop_unregister(op, i, j);
  72                 }
  73         }
  74 }
  75
  76 void
  77 ase_binary_optable_init(void)
  78 {
  79         ase_binary_operation_t op;
  80         for (op = ASE_BINARY_FIRST_OP; op < N_ASE_BINARY_OPS; op++) {
  81                 _ase_binary_optable_init(op);
  82         }
  83 }
  84
  85 \f
  86 DEFUN("+", Fent_binop_sum, 0, MANY, 0, /*
  87 Return sum of any number of arguments.
  88 The arguments should all be numbers, characters or markers.
  89 */
  90       (int nargs, Lisp_Object *args))
  91 {
  92         if (nargs == 0)
  93                 return Qzero;
  94
  95         return ent_binop_many(ASE_BINARY_OP_SUM, nargs, args);
  96 }
  97
  98 DEFUN("1+", Fadd1, 1, 1, 0,     /*
  99 Return NUMBER plus one.  NUMBER may be a number, character or marker.
 100 Markers and characters are converted to integers.
 101 */
 102       (number))
 103 {
 104         return ent_binop(ASE_BINARY_OP_SUM, number, Qone);
 105 }
 106
 107 DEFUN("-", Fent_binop_diff, 1, MANY, 0, /*
 108 Negate number or subtract numbers, characters or markers.
 109 With one arg, negates it.  With more than one arg,
 110 subtracts all args left-associatively.
 111 */
 112       (int nargs, Lisp_Object *args))
 113 {
 114         if (nargs == 1)
 115                 return ent_unop(ASE_UNARY_OP_NEG, args[0]);
 116
 117         return ent_binop_many(ASE_BINARY_OP_DIFF, nargs, args);
 118 }
 119
 120 DEFUN("1-", Fsub1, 1, 1, 0,     /*
 121 Return NUMBER minus one.  NUMBER may be a number, character or marker.
 122 Markers and characters are converted to integers.
 123 */
 124       (number))
 125 {
 126         return ent_binop(ASE_BINARY_OP_DIFF, number, Qone);
 127 }
 128
 129 DEFUN("*", Fent_binop_prod, 0, MANY, 0, /*
 130 Return product of any number of arguments.
 131 The arguments should all be numbers, characters or markers.
 132 */
 133       (int nargs, Lisp_Object *args))
 134 {
 135         if (nargs == 0)
 136                 return Qone;
 137
 138         return ent_binop_many(ASE_BINARY_OP_PROD, nargs, args);
 139 }
 140
 141 DEFUN("/", Fent_binop_divquo, 1, MANY, 0, /*
 142 Return first argument divided by all the remaining arguments.
 143 The arguments must be numbers, characters or markers.
 144 With one argument, reciprocates the argument.
 145 */
 146       (int nargs, Lisp_Object *args))
 147 {
 148         if (!common_lisp_slash)
 149                 return Fent_binop_div(nargs, args);
 150         else
 151                 return Fent_binop_quo(nargs, args);
 152 }
 153
 154 DEFUN("div", Fent_binop_div, 1, MANY, 0, /*
 155 Return the division of the first argument by all remaining
 156 arguments, possibly leaving a rest.
 157
 158 The arguments must be numbers, characters or markers.
 159 With one argument, reciprocates the argument.
 160
 161 The division of `a' and `b' is defined as the largest number `c'
 162 such that \(* b c\) is less or equal `a'.
 163 Hereby, `c' lies in the larger category of `a' and `b'.
 164
 165 The rest can be queried by `mod'.
 166 */
 167       (int nargs, Lisp_Object *args))
 168 {
 169         if (nargs == 1)
 170                 return ent_binop(ASE_BINARY_OP_DIV, Qone, args[0]);
 171
 172         return ent_binop_many(ASE_BINARY_OP_DIV, nargs, args);
 173 }
 174
 175 DEFUN("//", Fent_binop_quo, 1, MANY, 0, /*
 176 Return first argument divided by all the remaining arguments.
 177 If a rest occurred, the category is enlarged, such that
 178 the division can be performed without leaving a rest.
 179
 180 The arguments must be numbers, characters or markers.
 181 With one argument, reciprocates the argument.
 182 */
 183       (int nargs, Lisp_Object * args))
 184 {
 185         if (nargs == 1)
 186                 return ent_binop(ASE_BINARY_OP_QUO, Qone, args[0]);
 187
 188         return ent_binop_many(ASE_BINARY_OP_QUO, nargs, args);
 189 }
 190
 191 DEFUN("%", Fent_binop_rem, 2, 2, 0,     /*
 192 Return remainder of first arg divided by second.
 193 Both must be integers, characters or markers.
 194 */
 195       (number1, number2))
 196 {
 197         return ent_binop(ASE_BINARY_OP_REM, number1, number2);
 198 }
 199
 200 DEFUN("mod", Fent_binop_mod, 2, 2, 0,   /*
 201 Return NUMBER modulo MODULUS.
 202 The result falls in [0, MODULUS)
 203 NUMBER must be a number and MODULUS must be a comparable,
 204 a character or marker.
 205
 206 The result value lies in the larger category of NUMBER
 207 and MODULUS.
 208 */
 209       (number, modulus))
 210 {
 211         return ent_binop(ASE_BINARY_OP_MOD, number, modulus);
 212 }
 213
 214 DEFUN("^", Fent_binop_pow, 2, 2, 0,     /*
 215 Return the power NUMBER1 ^ NUMBER2.
 216 */
 217       (number1, number2))
 218 {
 219         return ent_binop(ASE_BINARY_OP_POW, number1, number2);
 220 }
 221
 222 \f
 223 void
 224 syms_of_ent_binary_op(void)
 225 {
 226         DEFSUBR(Fent_binop_sum);
 227         DEFSUBR(Fadd1);
 228         DEFSUBR(Fent_binop_diff);
 229         DEFSUBR(Fsub1);
 230         DEFSUBR(Fent_binop_prod);
 231         DEFSUBR(Fent_binop_divquo);
 232         DEFSUBR(Fent_binop_div);
 233         DEFSUBR(Fent_binop_quo);
 234
 235         DEFSUBR(Fent_binop_rem);
 236         DEFSUBR(Fent_binop_mod);
 237
 238         DEFSUBR(Fent_binop_pow);
 239 }
 240
 241 void
 242 vars_of_ent_binary_op(void)
 243 {
 244         common_lisp_slash = 0;
 245         DEFVAR_BOOL("common-lisp-slash", &common_lisp_slash     /*
 246 If non-nil the function `/' behaves like the common lisp function,
 247 that is returns a rational when the arguments are either rationals
 248 or rational integers.
 249                                                                 */ );
 250 }
 251
 252 /* ent-binary-op.c ends here */