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

   1 /*
   2   ent-binary-rel.c -- Global Binary Relations
   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-rel.h"
  42
  43 ase_binary_relation_f ase_binary_reltable
  44 [N_ASE_BINARY_OPS][ASE_OPTABLE_SIZE][ASE_OPTABLE_SIZE];
  45
  46 \f
  47 int
  48 ase_binary_relation_undefined(Lisp_Object l, Lisp_Object r)
  49 {
  50         Fsignal(Qrelation_error, list2(l, r));
  51         return 0;
  52 }
  53
  54 static inline void
  55 _ase_binary_reltable_init(ase_binary_relation_t rel)
  56 {
  57         int i, j;
  58         for (i = 0; i < ASE_OPTABLE_SIZE; i++) {
  59                 for (j = 0; j < ASE_OPTABLE_SIZE; j++) {
  60                         ent_binrel_unregister(rel, i, j);
  61                 }
  62         }
  63 }
  64
  65 inline void
  66 ase_binary_reltable_init(void)
  67 {
  68         ase_binary_relation_t rel;
  69         for (rel = ASE_BINARY_FIRST_REL; rel < N_ASE_BINARY_RELS; rel++) {
  70                 _ase_binary_reltable_init(rel);
  71         }
  72 }
  73
  74 \f
  75 DEFUN("<", Fent_binrel_lessp, 1, MANY, 0, /*
  76 Return t if the ARGUMENTS are strictly monotonically increasing.
  77 Arguments: &rest arguments
  78
  79 If there is more than one argument, the second argument, must be
  80 numerically greater than the first, and the third, must be numerically
  81 greater than the second, and so on. At least one argument is required.
  82
  83 The arguments may be numbers, characters or markers.
  84 */
  85       (int nargs, Lisp_Object *args))
  86 {
  87         if (nargs == 1)
  88                 return Qt;
  89
  90         if (ent_binrel_transitive_many(ASE_BINARY_REL_LESSP, nargs, args))
  91                 return Qt;
  92         else
  93                 return Qnil;
  94 }
  95
  96 DEFUN(">", Fent_binrel_greaterp, 1, MANY, 0, /*
  97 Return t if the ARGUMENTS are strictly monotonically decreasing.
  98 Arguments: &rest arguments
  99
 100 If there is more than one argument, the second argument, must be
 101 numerically smaller than the first, and the third, must be numerically
 102 smaller than the second, and so on. At least one argument is required.
 103
 104 The arguments may be numbers, characters or markers.
 105 */
 106       (int nargs, Lisp_Object *args))
 107 {
 108         if (nargs == 1)
 109                 return Qt;
 110
 111         if (ent_binrel_transitive_many(ASE_BINARY_REL_GREATERP, nargs, args))
 112                 return Qt;
 113         else
 114                 return Qnil;
 115 }
 116
 117 DEFUN("<=", Fent_binrel_lessequalp, 1, MANY, 0, /*
 118 Return t if the ARGUMENTS are monotonically decreasing.
 119 Arguments: &rest arguments
 120
 121 If there is more than one argument, the second argument, must be
 122 numerically greater than or equal to the first, and the third, must
 123 be numerically greater than or equal to the second, and so on. At
 124 least one argument is required.
 125
 126 The arguments may be numbers, characters or markers.
 127 */
 128       (int nargs, Lisp_Object * args))
 129 {
 130         if (nargs == 1)
 131                 return Qt;
 132
 133         if (ent_binrel2_transitive_many(
 134                     ASE_BINARY_REL_LESSP, ASE_BINARY_REL_EQUALP,
 135                     nargs, args))
 136                 return Qt;
 137         else
 138                 return Qnil;
 139 }
 140
 141 DEFUN(">=", Fent_binrel_greaterequalp, 1, MANY, 0, /*
 142 Return t if the ARGUMENTS are monotonically increasing.
 143 Arguments: &rest arguments
 144
 145 If there is more than one argument, the second argument, must be
 146 numerically smaller than or equal to the first, and the third, must
 147 be numerically smaller than or equal to the second, and so on. At
 148 least one argument is required.
 149
 150 The arguments may be numbers, characters or markers.
 151 */
 152       (int nargs, Lisp_Object *args))
 153 {
 154         if (nargs == 1)
 155                 return Qt;
 156
 157         if (ent_binrel2_transitive_many(
 158                     ASE_BINARY_REL_GREATERP, ASE_BINARY_REL_EQUALP,
 159                     nargs, args))
 160                 return Qt;
 161         else
 162                 return Qnil;
 163 }
 164
 165 DEFUN("=", Fent_binrel_equalp, 1, MANY, 0, /*
 166 Return t if all the arguments are numerically equal.
 167 Arguments: &rest arguments
 168
 169 The arguments may be numbers, characters or markers.
 170 */
 171       (int nargs, Lisp_Object *args))
 172 {
 173         if (nargs == 1)
 174                 return Qt;
 175
 176         if (ent_binrel_transitive_many(ASE_BINARY_REL_EQUALP, nargs, args))
 177                 return Qt;
 178         else
 179                 return Qnil;
 180 }
 181
 182 DEFUN("/=", Fent_binrel_neqp, 1, MANY, 0, /*
 183 Return t if no two arguments are numerically equal.
 184 Arguments: &rest arguments
 185
 186 The arguments may be numbers, characters or markers.
 187 */
 188       (int nargs, Lisp_Object *args))
 189 {
 190         if (nargs == 1)
 191                 return Qt;
 192
 193         if (ent_binrel_intransitive_many(ASE_BINARY_REL_NEQP, nargs, args))
 194                 return Qt;
 195         else
 196                 return Qnil;
 197 }
 198
 199
 200 DEFUN("min", Fmin, 1, MANY, 0, /*
 201 Return smallest of all the arguments.
 202 All arguments must be numbers, characters or markers.
 203 The value is always a number; markers and characters are converted
 204 to numbers.
 205 */
 206       (int nargs, Lisp_Object *args))
 207 {
 208         REGISTER int i, minindex;
 209         Lisp_Object compmin, compi;
 210         ase_object_type_t nti, ntmin;
 211
 212         minindex = 0;
 213         compmin = args[minindex];
 214         ntmin = ase_optable_index(compmin);
 215
 216         for (i = 1; i < nargs; i++) {
 217                 compi = args[i];
 218                 nti = ase_optable_index(compi);
 219
 220                 if (_ent_binrel(ASE_BINARY_REL_LESSP,
 221                                 nti, compi, ntmin, compmin)) {
 222                          minindex = i;
 223                          ntmin = nti;
 224                          compmin = compi;
 225                 }
 226         }
 227         return args[minindex];
 228 }
 229
 230 DEFUN("max", Fmax, 1, MANY, 0, /*
 231 Return largest of all the arguments.
 232 All arguments must be numbers, characters or markers.
 233 The value is always a number; markers and characters are converted
 234 to numbers.
 235 */
 236       (int nargs, Lisp_Object *args))
 237 {
 238         REGISTER int i, maxindex;
 239         Lisp_Object compmax, compi;
 240         ase_object_type_t nti, ntmax;
 241
 242         maxindex = 0;
 243         compmax = args[maxindex];
 244         ntmax = ase_optable_index(compmax);
 245
 246         for (i = 1; i < nargs; i++) {
 247                 compi = args[i];
 248                 nti = ase_optable_index(compi);
 249
 250                 if (_ent_binrel(ASE_BINARY_REL_GREATERP,
 251                                 nti, compi, ntmax, compmax)) {
 252                          maxindex = i;
 253                          ntmax = nti;
 254                          compmax = compi;
 255                 }
 256         }
 257         return args[maxindex];
 258 }
 259
 260 \f
 261 /* convenience functions */
 262
 263 \f
 264 void
 265 syms_of_ent_binary_rel(void)
 266 {
 267         DEFSUBR(Fent_binrel_lessp);
 268         DEFSUBR(Fent_binrel_greaterp);
 269         DEFSUBR(Fent_binrel_lessequalp);
 270         DEFSUBR(Fent_binrel_greaterequalp);
 271         DEFSUBR(Fent_binrel_equalp);
 272         DEFSUBR(Fent_binrel_neqp);
 273         DEFSUBR(Fmax);
 274         DEFSUBR(Fmin);
 275 }
 276
 277 void
 278 vars_of_ent_binary_rel(void)
 279 {
 280 }
 281
 282 /* ent-binary-rel.c ends here */