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