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