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