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 <stdarg.h>
  25
  26 #include "libguile/_scm.h"
  27 #include "libguile/procprop.h"
  28 #include "libguile/root.h"
  29
  30 #include "libguile/gsubr.h"
  31 #include "libguile/deprecation.h"
  32
  33 #include "libguile/private-options.h"
  34 \f
  35 /*
  36  * gsubr.c
  37  * Provide `gsubrs' -- subrs taking a prescribed number of required, optional,
  38  * and rest arguments.
  39  */
  40
  41 /* #define GSUBR_TEST */
  42
  43 SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
  44
  45 static SCM
  46 create_gsubr (int define, const char *name,
  47               unsigned int req, unsigned int opt, unsigned int rst,
  48               SCM (*fcn) ())
  49 {
  50   SCM subr;
  51
  52   switch (SCM_GSUBR_MAKTYPE (req, opt, rst))
  53     {
  54     case SCM_GSUBR_MAKTYPE(0, 0, 0):
  55       subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn);
  56       break;
  57     case SCM_GSUBR_MAKTYPE(1, 0, 0):
  58       subr = scm_c_make_subr (name, scm_tc7_subr_1, fcn);
  59       break;
  60     case SCM_GSUBR_MAKTYPE(0, 1, 0):
  61       subr = scm_c_make_subr (name, scm_tc7_subr_1o, fcn);
  62       break;
  63     case SCM_GSUBR_MAKTYPE(1, 1, 0):
  64       subr = scm_c_make_subr (name, scm_tc7_subr_2o, fcn);
  65       break;
  66     case SCM_GSUBR_MAKTYPE(2, 0, 0):
  67       subr = scm_c_make_subr (name, scm_tc7_subr_2, fcn);
  68       break;
  69     case SCM_GSUBR_MAKTYPE(3, 0, 0):
  70       subr = scm_c_make_subr (name, scm_tc7_subr_3, fcn);
  71       break;
  72     case SCM_GSUBR_MAKTYPE(0, 0, 1):
  73       subr = scm_c_make_subr (name, scm_tc7_lsubr, fcn);
  74       break;
  75     case SCM_GSUBR_MAKTYPE(2, 0, 1):
  76       subr = scm_c_make_subr (name, scm_tc7_lsubr_2, fcn);
  77       break;
  78     default:
  79       {
  80         unsigned type;
  81
  82         type = SCM_GSUBR_MAKTYPE (req, opt, rst);
  83         if (SCM_GSUBR_REQ (type) != req
  84             || SCM_GSUBR_OPT (type) != opt
  85             || SCM_GSUBR_REST (type) != rst)
  86           scm_out_of_range ("create_gsubr", scm_from_uint (req + opt + rst));
  87
  88         subr = scm_c_make_subr (name, scm_tc7_gsubr | (type << 8U),
  89                                 fcn);
  90       }
  91     }
  92
  93   if (define)
  94     scm_define (SCM_SNAME (subr), subr);
  95
  96   return subr;
  97 }
  98
  99 SCM
 100 scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
 101 {
 102   return create_gsubr (0, name, req, opt, rst, fcn);
 103 }
 104
 105 SCM
 106 scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
 107 {
 108   return create_gsubr (1, name, req, opt, rst, fcn);
 109 }
 110
 111 static SCM
 112 create_gsubr_with_generic (int define,
 113                            const char *name,
 114                            int req,
 115                            int opt,
 116                            int rst,
 117                            SCM (*fcn)(),
 118                            SCM *gf)
 119 {
 120   SCM subr;
 121
 122   switch (SCM_GSUBR_MAKTYPE(req, opt, rst))
 123     {
 124     case SCM_GSUBR_MAKTYPE(0, 0, 0):
 125       subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_0, fcn, gf);
 126       goto create_subr;
 127     case SCM_GSUBR_MAKTYPE(1, 0, 0):
 128       subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1, fcn, gf);
 129       goto create_subr;
 130     case SCM_GSUBR_MAKTYPE(0, 1, 0):
 131       subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1o, fcn, gf);
 132       goto create_subr;
 133     case SCM_GSUBR_MAKTYPE(1, 1, 0):
 134       subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2o, fcn, gf);
 135       goto create_subr;
 136     case SCM_GSUBR_MAKTYPE(2, 0, 0):
 137       subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2, fcn, gf);
 138       goto create_subr;
 139     case SCM_GSUBR_MAKTYPE(3, 0, 0):
 140       subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_3, fcn, gf);
 141       goto create_subr;
 142     case SCM_GSUBR_MAKTYPE(0, 0, 1):
 143       subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr, fcn, gf);
 144       goto create_subr;
 145     case SCM_GSUBR_MAKTYPE(2, 0, 1):
 146       subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr_2, fcn, gf);
 147     create_subr:
 148       if (define)
 149         scm_define (SCM_SNAME (subr), subr);
 150       return subr;
 151     default:
 152       ;
 153     }
 154   scm_misc_error ("scm_c_make_gsubr_with_generic",
 155                   "can't make primitive-generic with this arity",
 156                   SCM_EOL);
 157   return SCM_BOOL_F; /* never reached */
 158 }
 159
 160 SCM
 161 scm_c_make_gsubr_with_generic (const char *name,
 162                                int req,
 163                                int opt,
 164                                int rst,
 165                                SCM (*fcn)(),
 166                                SCM *gf)
 167 {
 168   return create_gsubr_with_generic (0, name, req, opt, rst, fcn, gf);
 169 }
 170
 171 SCM
 172 scm_c_define_gsubr_with_generic (const char *name,
 173                                  int req,
 174                                  int opt,
 175                                  int rst,
 176                                  SCM (*fcn)(),
 177                                  SCM *gf)
 178 {
 179   return create_gsubr_with_generic (1, name, req, opt, rst, fcn, gf);
 180 }
 181
 182 /* Apply PROC, a gsubr, to the ARGC arguments in ARGV.  ARGC is expected to
 183    match the number of arguments of the underlying C function.  */
 184 static SCM
 185 gsubr_apply_raw (SCM proc, unsigned int argc, const SCM *argv)
 186 {
 187   SCM (*fcn) ();
 188   unsigned int type, argc_max;
 189
 190   type = SCM_GSUBR_TYPE (proc);
 191   argc_max = SCM_GSUBR_REQ (type) + SCM_GSUBR_OPT (type)
 192     + SCM_GSUBR_REST (type);
 193
 194   if (SCM_UNLIKELY (argc != argc_max))
 195     /* We expect the exact argument count.  */
 196     scm_wrong_num_args (SCM_SNAME (proc));
 197
 198   fcn = SCM_SUBRF (proc);
 199
 200   switch (argc)
 201     {
 202     case 0:
 203       return (*fcn) ();
 204     case 1:
 205       return (*fcn) (argv[0]);
 206     case 2:
 207       return (*fcn) (argv[0], argv[1]);
 208     case 3:
 209       return (*fcn) (argv[0], argv[1], argv[2]);
 210     case 4:
 211       return (*fcn) (argv[0], argv[1], argv[2], argv[3]);
 212     case 5:
 213       return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4]);
 214     case 6:
 215       return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5]);
 216     case 7:
 217       return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
 218                      argv[6]);
 219     case 8:
 220       return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
 221                      argv[6], argv[7]);
 222     case 9:
 223       return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
 224                      argv[6], argv[7], argv[8]);
 225     case 10:
 226       return (*fcn) (argv[0], argv[1], argv[2], argv[3], argv[4], argv[5],
 227                      argv[6], argv[7], argv[8], argv[9]);
 228     default:
 229       scm_misc_error ((char *) SCM_SNAME (proc),
 230                       "gsubr invocation with more than 10 arguments not implemented",
 231                       SCM_EOL);
 232     }
 233
 234   return SCM_BOOL_F; /* Never reached. */
 235 }
 236
 237 /* Apply PROC, a gsubr, to the given arguments.  Missing optional arguments
 238    are added, and rest arguments are turned into a list.  */
 239 SCM
 240 scm_i_gsubr_apply (SCM proc, SCM arg, ...)
 241 {
 242   unsigned int type, argc, argc_max;
 243   SCM *argv;
 244   va_list arg_list;
 245
 246   type = SCM_GSUBR_TYPE (proc);
 247   argc_max = SCM_GSUBR_REQ (type) + SCM_GSUBR_OPT (type);
 248   argv = alloca ((argc_max + SCM_GSUBR_REST (type)) * sizeof (*argv));
 249
 250   va_start (arg_list, arg);
 251
 252   for (argc = 0;
 253        !SCM_UNBNDP (arg) && argc < argc_max;
 254        argc++, arg = va_arg (arg_list, SCM))
 255     argv[argc] = arg;
 256
 257   if (SCM_UNLIKELY (argc < SCM_GSUBR_REQ (type)))
 258     scm_wrong_num_args (SCM_SNAME (proc));
 259
 260   /* Fill in optional arguments that were not passed.  */
 261   while (argc < argc_max)
 262     argv[argc++] = SCM_UNDEFINED;
 263
 264   if (SCM_GSUBR_REST (type))
 265     {
 266       /* Accumulate rest arguments in a list.  */
 267       SCM *rest_loc;
 268
 269       argv[argc_max] = SCM_EOL;
 270
 271       for (rest_loc = &argv[argc_max];
 272            !SCM_UNBNDP (arg);
 273            rest_loc = SCM_CDRLOC (*rest_loc), arg = va_arg (arg_list, SCM))
 274         *rest_loc = scm_cons (arg, SCM_EOL);
 275
 276       argc = argc_max + 1;
 277     }
 278
 279   va_end (arg_list);
 280
 281   return gsubr_apply_raw (proc, argc, argv);
 282 }
 283
 284 /* Apply SELF, a gsubr, to the arguments listed in ARGS.  Missing optional
 285    arguments are added, and rest arguments are kept into a list.  */
 286 SCM
 287 scm_i_gsubr_apply_list (SCM self, SCM args)
 288 #define FUNC_NAME "scm_i_gsubr_apply"
 289 {
 290   SCM v[SCM_GSUBR_MAX];
 291   unsigned int typ = SCM_GSUBR_TYPE (self);
 292   long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ);
 293
 294   for (i = 0; i < SCM_GSUBR_REQ (typ); i++) {
 295     if (scm_is_null (args))
 296       scm_wrong_num_args (SCM_SNAME (self));
 297     v[i] = SCM_CAR(args);
 298     args = SCM_CDR(args);
 299   }
 300   for (; i < SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ); i++) {
 301     if (SCM_NIMP (args)) {
 302       v[i] = SCM_CAR (args);
 303       args = SCM_CDR(args);
 304     }
 305     else
 306       v[i] = SCM_UNDEFINED;
 307   }
 308   if (SCM_GSUBR_REST(typ))
 309     v[i] = args;
 310   else if (!scm_is_null (args))
 311     scm_wrong_num_args (SCM_SNAME (self));
 312
 313   return gsubr_apply_raw (self, n, v);
 314 }
 315 #undef FUNC_NAME
 316
 317
 318 #ifdef GSUBR_TEST
 319 /* A silly example, taking 2 required args, 1 optional, and
 320    a scm_list of rest args
 321    */
 322 SCM
 323 gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst)
 324 {
 325   scm_puts ("gsubr-2-1-l:\n req1: ", scm_cur_outp);
 326   scm_display(req1, scm_cur_outp);
 327   scm_puts ("\n req2: ", scm_cur_outp);
 328   scm_display(req2, scm_cur_outp);
 329   scm_puts ("\n opt: ", scm_cur_outp);
 330   scm_display(opt, scm_cur_outp);
 331   scm_puts ("\n rest: ", scm_cur_outp);
 332   scm_display(rst, scm_cur_outp);
 333   scm_newline(scm_cur_outp);
 334   return SCM_UNSPECIFIED;
 335 }
 336 #endif
 337
 338
 339 void
 340 scm_init_gsubr()
 341 {
 342 #ifdef GSUBR_TEST
 343   scm_c_define_gsubr ("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */
 344 #endif
 345
 346 #include "libguile/gsubr.x"
 347 }
 348
 349 /*
 350   Local Variables:
 351   c-file-style: "gnu"
 352   End:
 353 */