2 ent-binary-op.c -- Global Binary Operations
3 Copyright (C) 2006, 2007, 2008 Sebastian Freundt
5 Author: Sebastian Freundt <hroptatyr@sxemacs.org>
7 * This file is part of SXEmacs.
9 * Redistribution and use in source and binary forms, with or without
10 * modification, are permitted provided that the following conditions
13 * 1. Redistributions of source code must retain the above copyright
14 * notice, this list of conditions and the following disclaimer.
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.
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.
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.
37 /* Synched up with: Not in FSF. */
41 #include "ent-binary-op.h"
42 #include "ent-unary-op.h"
44 int common_lisp_slash;
45 ase_binary_operation_f ase_binary_optable
46 [N_ASE_BINARY_OPS][ASE_OPTABLE_SIZE][ASE_OPTABLE_SIZE];
50 ase_binary_operation_undefined(Lisp_Object l, Lisp_Object r)
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));
58 Fsignal(Qoperation_error, list2(l, r));
63 _ase_binary_optable_init(ase_binary_operation_t op)
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);
74 ase_binary_optable_init(void)
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);
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.
87 (int nargs, Lisp_Object *args))
92 return ent_binop_many(ASE_BINARY_OP_SUM, nargs, args);
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.
101 return ent_binop(ASE_BINARY_OP_SUM, number, Qone);
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.
109 (int nargs, Lisp_Object *args))
112 return ent_unop(ASE_UNARY_OP_NEG, args[0]);
114 return ent_binop_many(ASE_BINARY_OP_DIFF, nargs, args);
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.
123 return ent_binop(ASE_BINARY_OP_DIFF, number, Qone);
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.
130 (int nargs, Lisp_Object *args))
135 return ent_binop_many(ASE_BINARY_OP_PROD, nargs, args);
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.
143 (int nargs, Lisp_Object *args))
145 if (!common_lisp_slash)
146 return Fent_binop_div(nargs, args);
148 return Fent_binop_quo(nargs, args);
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.
155 The arguments must be numbers, characters or markers.
156 With one argument, reciprocates the argument.
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'.
162 The rest can be queried by `mod'.
164 (int nargs, Lisp_Object *args))
167 return ent_binop(ASE_BINARY_OP_DIV, Qone, args[0]);
169 return ent_binop_many(ASE_BINARY_OP_DIV, nargs, args);
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.
177 The arguments must be numbers, characters or markers.
178 With one argument, reciprocates the argument.
180 (int nargs, Lisp_Object * args))
183 return ent_binop(ASE_BINARY_OP_QUO, Qone, args[0]);
185 return ent_binop_many(ASE_BINARY_OP_QUO, nargs, args);
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.
194 return ent_binop(ASE_BINARY_OP_REM, number1, number2);
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.
203 The result value lies in the larger category of NUMBER
208 return ent_binop(ASE_BINARY_OP_MOD, number, modulus);
211 DEFUN("^", Fent_binop_pow, 2, 2, 0, /*
212 Return the power NUMBER1 ^ NUMBER2.
216 return ent_binop(ASE_BINARY_OP_POW, number1, number2);
221 syms_of_ent_binary_op(void)
223 DEFSUBR(Fent_binop_sum);
225 DEFSUBR(Fent_binop_diff);
227 DEFSUBR(Fent_binop_prod);
228 DEFSUBR(Fent_binop_divquo);
229 DEFSUBR(Fent_binop_div);
230 DEFSUBR(Fent_binop_quo);
232 DEFSUBR(Fent_binop_rem);
233 DEFSUBR(Fent_binop_mod);
235 DEFSUBR(Fent_binop_pow);
239 vars_of_ent_binary_op(void)
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.
249 /* ent-binary-op.c ends here */