libguile/gsubr.c

   1 /* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
   2  *
   3  * This library is free software; you can redistribute it and/or
   4  * modify it under the terms of the GNU Lesser General Public
   5  * License as published by the Free Software Foundation; either
   6  * version 2.1 of the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  11  * Lesser General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU Lesser General Public
  14  * License along with this library; if not, write to the Free Software
  15  * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  16  */
  17
  18 \f
  19 #ifdef HAVE_CONFIG_H
  20 # include <config.h>
  21 #endif
  22
  23 #include <stdio.h>
  24 #include "libguile/_scm.h"
  25 #include "libguile/procprop.h"
  26 #include "libguile/root.h"
  27
  28 #include "libguile/gsubr.h"
  29 #include "libguile/deprecation.h"
  30
  31 #include "libguile/private-options.h"
  32 \f
  33 /*
  34  * gsubr.c
  35  * Provide `gsubrs' -- subrs taking a prescribed number of required, optional,
  36  * and rest arguments.
  37  */
  38
  39 /* #define GSUBR_TEST */
  40
  41 SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
  42
  43 static SCM
  44 create_gsubr (int define, const char *name,
  45               unsigned int req, unsigned int opt, unsigned int rst,
  46               SCM (*fcn) ())
  47 {
  48   SCM subr;
  49
  50   switch (SCM_GSUBR_MAKTYPE (req, opt, rst))
  51     {
  52     case SCM_GSUBR_MAKTYPE(0, 0, 0):
  53       subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn);
  54       break;
  55     case SCM_GSUBR_MAKTYPE(1, 0, 0):
  56       subr = scm_c_make_subr (name, scm_tc7_subr_1, fcn);
  57       break;
  58     case SCM_GSUBR_MAKTYPE(0, 1, 0):
  59       subr = scm_c_make_subr (name, scm_tc7_subr_1o, fcn);
  60       break;
  61     case SCM_GSUBR_MAKTYPE(1, 1, 0):
  62       subr = scm_c_make_subr (name, scm_tc7_subr_2o, fcn);
  63       break;
  64     case SCM_GSUBR_MAKTYPE(2, 0, 0):
  65       subr = scm_c_make_subr (name, scm_tc7_subr_2, fcn);
  66       break;
  67     case SCM_GSUBR_MAKTYPE(3, 0, 0):
  68       subr = scm_c_make_subr (name, scm_tc7_subr_3, fcn);
  69       break;
  70     case SCM_GSUBR_MAKTYPE(0, 0, 1):
  71       subr = scm_c_make_subr (name, scm_tc7_lsubr, fcn);
  72       break;
  73     case SCM_GSUBR_MAKTYPE(2, 0, 1):
  74       subr = scm_c_make_subr (name, scm_tc7_lsubr_2, fcn);
  75       break;
  76     default:
  77       {
  78         unsigned type;
  79
  80         type = SCM_GSUBR_MAKTYPE (req, opt, rst);
  81         if (SCM_GSUBR_REQ (type) != req
  82             || SCM_GSUBR_OPT (type) != opt
  83             || SCM_GSUBR_REST (type) != rst)
  84           scm_out_of_range ("create_gsubr", scm_from_uint (req + opt + rst));
  85
  86         subr = scm_c_make_subr (name, scm_tc7_gsubr | (type << 8U),
  87                                 fcn);
  88       }
  89     }
  90
  91   if (define)
  92     scm_define (SCM_SNAME (subr), subr);
  93
  94   return subr;
  95 }
  96
  97 SCM
  98 scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
  99 {
 100   return create_gsubr (0, name, req, opt, rst, fcn);
 101 }
 102
 103 SCM
 104 scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
 105 {
 106   return create_gsubr (1, name, req, opt, rst, fcn);
 107 }
 108
 109 static SCM
 110 create_gsubr_with_generic (int define,
 111                            const char *name,
 112                            int req,
 113                            int opt,
 114                            int rst,
 115                            SCM (*fcn)(),
 116                            SCM *gf)
 117 {
 118   SCM subr;
 119
 120   switch (SCM_GSUBR_MAKTYPE(req, opt, rst))
 121     {
 122     case SCM_GSUBR_MAKTYPE(0, 0, 0):
 123       subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_0, fcn, gf);
 124       goto create_subr;
 125     case SCM_GSUBR_MAKTYPE(1, 0, 0):
 126       subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1, fcn, gf);
 127       goto create_subr;
 128     case SCM_GSUBR_MAKTYPE(0, 1, 0):
 129       subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1o, fcn, gf);
 130       goto create_subr;
 131     case SCM_GSUBR_MAKTYPE(1, 1, 0):
 132       subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2o, fcn, gf);
 133       goto create_subr;
 134     case SCM_GSUBR_MAKTYPE(2, 0, 0):
 135       subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2, fcn, gf);
 136       goto create_subr;
 137     case SCM_GSUBR_MAKTYPE(3, 0, 0):
 138       subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_3, fcn, gf);
 139       goto create_subr;
 140     case SCM_GSUBR_MAKTYPE(0, 0, 1):
 141       subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr, fcn, gf);
 142       goto create_subr;
 143     case SCM_GSUBR_MAKTYPE(2, 0, 1):
 144       subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr_2, fcn, gf);
 145     create_subr:
 146       if (define)
 147         scm_define (SCM_SNAME (subr), subr);
 148       return subr;
 149     default:
 150       ;
 151     }
 152   scm_misc_error ("scm_c_make_gsubr_with_generic",
 153                   "can't make primitive-generic with this arity",
 154                   SCM_EOL);
 155   return SCM_BOOL_F; /* never reached */
 156 }
 157
 158 SCM
 159 scm_c_make_gsubr_with_generic (const char *name,
 160                                int req,
 161                                int opt,
 162                                int rst,
 163                                SCM (*fcn)(),
 164                                SCM *gf)
 165 {
 166   return create_gsubr_with_generic (0, name, req, opt, rst, fcn, gf);
 167 }
 168
 169 SCM
 170 scm_c_define_gsubr_with_generic (const char *name,
 171                                  int req,
 172                                  int opt,
 173                                  int rst,
 174                                  SCM (*fcn)(),
 175                                  SCM *gf)
 176 {
 177   return create_gsubr_with_generic (1, name, req, opt, rst, fcn, gf);
 178 }
 179
 180
 181 SCM
 182 scm_gsubr_apply (SCM args)
 183 #define FUNC_NAME "scm_gsubr_apply"
 184 {
 185   SCM self = SCM_CAR (args);
 186   SCM (*fcn)() = SCM_SUBRF (self);
 187   SCM v[SCM_GSUBR_MAX];
 188   unsigned int typ = SCM_GSUBR_TYPE (self);
 189   long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ);
 190
 191   args = SCM_CDR (args);
 192   for (i = 0; i < SCM_GSUBR_REQ (typ); i++) {
 193     if (scm_is_null (args))
 194       scm_wrong_num_args (SCM_SNAME (self));
 195     v[i] = SCM_CAR(args);
 196     args = SCM_CDR(args);
 197   }
 198   for (; i < SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ); i++) {
 199     if (SCM_NIMP (args)) {
 200       v[i] = SCM_CAR (args);
 201       args = SCM_CDR(args);
 202     }
 203     else
 204       v[i] = SCM_UNDEFINED;
 205   }
 206   if (SCM_GSUBR_REST(typ))
 207     v[i] = args;
 208   else if (!scm_is_null (args))
 209     scm_wrong_num_args (SCM_SNAME (self));
 210   switch (n) {
 211   case 2: return (*fcn)(v[0], v[1]);
 212   case 3: return (*fcn)(v[0], v[1], v[2]);
 213   case 4: return (*fcn)(v[0], v[1], v[2], v[3]);
 214   case 5: return (*fcn)(v[0], v[1], v[2], v[3], v[4]);
 215   case 6: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5]);
 216   case 7: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6]);
 217   case 8: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7]);
 218   case 9: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8]);
 219   case 10: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8], v[9]);
 220   default:
 221     scm_misc_error ((char *) SCM_SNAME (self),
 222                     "gsubr invocation with more than 10 arguments not implemented",
 223                     SCM_EOL);
 224   }
 225   return SCM_BOOL_F; /* Never reached. */
 226 }
 227 #undef FUNC_NAME
 228
 229
 230 #ifdef GSUBR_TEST
 231 /* A silly example, taking 2 required args, 1 optional, and
 232    a scm_list of rest args
 233    */
 234 SCM
 235 gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst)
 236 {
 237   scm_puts ("gsubr-2-1-l:\n req1: ", scm_cur_outp);
 238   scm_display(req1, scm_cur_outp);
 239   scm_puts ("\n req2: ", scm_cur_outp);
 240   scm_display(req2, scm_cur_outp);
 241   scm_puts ("\n opt: ", scm_cur_outp);
 242   scm_display(opt, scm_cur_outp);
 243   scm_puts ("\n rest: ", scm_cur_outp);
 244   scm_display(rst, scm_cur_outp);
 245   scm_newline(scm_cur_outp);
 246   return SCM_UNSPECIFIED;
 247 }
 248 #endif
 249
 250
 251 void
 252 scm_init_gsubr()
 253 {
 254 #ifdef GSUBR_TEST
 255   scm_c_define_gsubr ("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */
 256 #endif
 257
 258 #include "libguile/gsubr.x"
 259 }
 260
 261 /*
 262   Local Variables:
 263   c-file-style: "gnu"
 264   End:
 265 */