[bpt/guile.git] / libguile / gsubr.c

/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public
 * License as published by the Free Software Foundation; either
 * version 2.1 of the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful,
 * but WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 */

\f
#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

#include <stdio.h>
#include "libguile/_scm.h"
#include "libguile/procprop.h"
#include "libguile/root.h"

#include "libguile/gsubr.h"
#include "libguile/deprecation.h"

#include "libguile/private-options.h"
\f
/*
 * gsubr.c
 * Provide `gsubrs' -- subrs taking a prescribed number of required, optional,
 * and rest arguments.
 */

/* #define GSUBR_TEST */

SCM_GLOBAL_SYMBOL (scm_sym_name, "name");

static SCM
create_gsubr (int define, const char *name,
	      unsigned int req, unsigned int opt, unsigned int rst,
	      SCM (*fcn) ())
{
  SCM subr;

  switch (SCM_GSUBR_MAKTYPE (req, opt, rst))
    {
    case SCM_GSUBR_MAKTYPE(0, 0, 0):
      subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn);
      break;
    case SCM_GSUBR_MAKTYPE(1, 0, 0):
      subr = scm_c_make_subr (name, scm_tc7_subr_1, fcn);
      break;
    case SCM_GSUBR_MAKTYPE(0, 1, 0):
      subr = scm_c_make_subr (name, scm_tc7_subr_1o, fcn);
      break;
    case SCM_GSUBR_MAKTYPE(1, 1, 0):
      subr = scm_c_make_subr (name, scm_tc7_subr_2o, fcn);
      break;
    case SCM_GSUBR_MAKTYPE(2, 0, 0):
      subr = scm_c_make_subr (name, scm_tc7_subr_2, fcn);
      break;
    case SCM_GSUBR_MAKTYPE(3, 0, 0):
      subr = scm_c_make_subr (name, scm_tc7_subr_3, fcn);
      break;
    case SCM_GSUBR_MAKTYPE(0, 0, 1):
      subr = scm_c_make_subr (name, scm_tc7_lsubr, fcn);
      break;
    case SCM_GSUBR_MAKTYPE(2, 0, 1):
      subr = scm_c_make_subr (name, scm_tc7_lsubr_2, fcn);
      break;
    default:
      {
	unsigned type;

	type = SCM_GSUBR_MAKTYPE (req, opt, rst);
	if (SCM_GSUBR_REQ (type) != req
	    || SCM_GSUBR_OPT (type) != opt
	    || SCM_GSUBR_REST (type) != rst)
	  scm_out_of_range ("create_gsubr", scm_from_uint (req + opt + rst));

	subr = scm_c_make_subr (name, scm_tc7_gsubr | (type << 8U),
				fcn);
      }
    }

  if (define)
    scm_define (SCM_SNAME (subr), subr);

  return subr;
}

SCM
scm_c_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
{
  return create_gsubr (0, name, req, opt, rst, fcn);
}

SCM
scm_c_define_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
{
  return create_gsubr (1, name, req, opt, rst, fcn);
}

static SCM
create_gsubr_with_generic (int define,
			   const char *name,
			   int req,
			   int opt,
			   int rst,
			   SCM (*fcn)(),
			   SCM *gf)
{
  SCM subr;

  switch (SCM_GSUBR_MAKTYPE(req, opt, rst))
    {
    case SCM_GSUBR_MAKTYPE(0, 0, 0):
      subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_0, fcn, gf);
      goto create_subr;
    case SCM_GSUBR_MAKTYPE(1, 0, 0):
      subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1, fcn, gf);
      goto create_subr;
    case SCM_GSUBR_MAKTYPE(0, 1, 0):
      subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_1o, fcn, gf);
      goto create_subr;
    case SCM_GSUBR_MAKTYPE(1, 1, 0):
      subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2o, fcn, gf);
      goto create_subr;
    case SCM_GSUBR_MAKTYPE(2, 0, 0):
      subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_2, fcn, gf);
      goto create_subr;
    case SCM_GSUBR_MAKTYPE(3, 0, 0):
      subr = scm_c_make_subr_with_generic (name, scm_tc7_subr_3, fcn, gf);
      goto create_subr;
    case SCM_GSUBR_MAKTYPE(0, 0, 1):
      subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr, fcn, gf);
      goto create_subr;
    case SCM_GSUBR_MAKTYPE(2, 0, 1):
      subr = scm_c_make_subr_with_generic (name, scm_tc7_lsubr_2, fcn, gf);
    create_subr:
      if (define)
	scm_define (SCM_SNAME (subr), subr);
      return subr;
    default:
      ;
    }
  scm_misc_error ("scm_c_make_gsubr_with_generic",
		  "can't make primitive-generic with this arity",
		  SCM_EOL);
  return SCM_BOOL_F; /* never reached */
}

SCM
scm_c_make_gsubr_with_generic (const char *name,
			       int req,
			       int opt,
			       int rst,
			       SCM (*fcn)(),
			       SCM *gf)
{
  return create_gsubr_with_generic (0, name, req, opt, rst, fcn, gf);
}

SCM
scm_c_define_gsubr_with_generic (const char *name,
				 int req,
				 int opt,
				 int rst,
				 SCM (*fcn)(),
				 SCM *gf)
{
  return create_gsubr_with_generic (1, name, req, opt, rst, fcn, gf);
}


SCM
scm_gsubr_apply (SCM args)
#define FUNC_NAME "scm_gsubr_apply"
{
  SCM self = SCM_CAR (args);
  SCM (*fcn)() = SCM_SUBRF (self);
  SCM v[SCM_GSUBR_MAX];
  unsigned int typ = SCM_GSUBR_TYPE (self);
  long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ);

  args = SCM_CDR (args);
  for (i = 0; i < SCM_GSUBR_REQ (typ); i++) {
    if (scm_is_null (args))
      scm_wrong_num_args (SCM_SNAME (self));
    v[i] = SCM_CAR(args);
    args = SCM_CDR(args);
  }
  for (; i < SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ); i++) {
    if (SCM_NIMP (args)) {
      v[i] = SCM_CAR (args);
      args = SCM_CDR(args);
    }
    else
      v[i] = SCM_UNDEFINED;
  }
  if (SCM_GSUBR_REST(typ))
    v[i] = args;
  else if (!scm_is_null (args))
    scm_wrong_num_args (SCM_SNAME (self));
  switch (n) {
  case 2: return (*fcn)(v[0], v[1]);
  case 3: return (*fcn)(v[0], v[1], v[2]);
  case 4: return (*fcn)(v[0], v[1], v[2], v[3]);
  case 5: return (*fcn)(v[0], v[1], v[2], v[3], v[4]);
  case 6: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5]);
  case 7: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6]);
  case 8: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7]);
  case 9: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8]);
  case 10: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8], v[9]);
  default:
    scm_misc_error ((char *) SCM_SNAME (self),
		    "gsubr invocation with more than 10 arguments not implemented",
		    SCM_EOL);
  }
  return SCM_BOOL_F; /* Never reached. */
}
#undef FUNC_NAME


#ifdef GSUBR_TEST
/* A silly example, taking 2 required args, 1 optional, and
   a scm_list of rest args
   */
SCM
gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst)
{
  scm_puts ("gsubr-2-1-l:\n req1: ", scm_cur_outp);
  scm_display(req1, scm_cur_outp);
  scm_puts ("\n req2: ", scm_cur_outp);
  scm_display(req2, scm_cur_outp);
  scm_puts ("\n opt: ", scm_cur_outp);
  scm_display(opt, scm_cur_outp);
  scm_puts ("\n rest: ", scm_cur_outp);
  scm_display(rst, scm_cur_outp);
  scm_newline(scm_cur_outp);
  return SCM_UNSPECIFIED;
}
#endif


void
scm_init_gsubr()
{
#ifdef GSUBR_TEST
  scm_c_define_gsubr ("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */
#endif

#include "libguile/gsubr.x"
}

/*
  Local Variables:
  c-file-style: "gnu"
  End:
*/
Commit	Line	Data
cce8b2ce	1	/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006, 2008, 2009 Free Software Foundation, Inc.
c0fa6561	2	*
73be1d9e MV	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.
c0fa6561	7	*
73be1d9e	8	* This library is distributed in the hope that it will be useful,
0f2d19dd	9	* but WITHOUT ANY WARRANTY; without even the implied warranty of
73be1d9e MV	10	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
73be1d9e MV	11	* Lesser General Public License for more details.
c0fa6561	12	*
73be1d9e MV	13	* You should have received a copy of the GNU Lesser General Public
73be1d9e MV	14	* License along with this library; if not, write to the Free Software
92205699	15	* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
73be1d9e	16	*/
1bbd0b84	17
0f2d19dd	18	\f
dbb605f5 LC	19	#ifdef HAVE_CONFIG_H
	20	# include <config.h>
	21	#endif
0f2d19dd JB	22
0f2d19dd JB	23	#include <stdio.h>
a0599745 MD	24	#include "libguile/_scm.h"
	25	#include "libguile/procprop.h"
	26	#include "libguile/root.h"
0f2d19dd	27
a0599745	28	#include "libguile/gsubr.h"
1be6b49c	29	#include "libguile/deprecation.h"
22fc179a HWN	30
22fc179a HWN	31	#include "libguile/private-options.h"
0f2d19dd JB	32	\f
	33	/*
	34	* gsubr.c
	35	* Provide `gsubrs' -- subrs taking a prescribed number of required, optional,
	36	* and rest arguments.
	37	*/
	38
952bedad	39	/* #define GSUBR_TEST */
0f2d19dd	40
85db4a2c DH	41	SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
85db4a2c DH	42
9d78586f	43	static SCM
c0fa6561	44	create_gsubr (int define, const char *name,
e20d7001 LC	45	unsigned int req, unsigned int opt, unsigned int rst,
e20d7001 LC	46	SCM (*fcn) ())
0f2d19dd	47	{
9d78586f MV	48	SCM subr;
	49
	50	switch (SCM_GSUBR_MAKTYPE (req, opt, rst))
0f2d19dd	51	{
9d78586f MV	52	case SCM_GSUBR_MAKTYPE(0, 0, 0):
9d78586f MV	53	subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn);
e20d7001	54	break;
9d78586f MV	55	case SCM_GSUBR_MAKTYPE(1, 0, 0):
9d78586f MV	56	subr = scm_c_make_subr (name, scm_tc7_subr_1, fcn);
e20d7001	57	break;
9d78586f MV	58	case SCM_GSUBR_MAKTYPE(0, 1, 0):
9d78586f MV	59	subr = scm_c_make_subr (name, scm_tc7_subr_1o, fcn);
e20d7001	60	break;
9d78586f MV	61	case SCM_GSUBR_MAKTYPE(1, 1, 0):
9d78586f MV	62	subr = scm_c_make_subr (name, scm_tc7_subr_2o, fcn);
e20d7001	63	break;
9d78586f MV	64	case SCM_GSUBR_MAKTYPE(2, 0, 0):
9d78586f MV	65	subr = scm_c_make_subr (name, scm_tc7_subr_2, fcn);
e20d7001	66	break;
9d78586f MV	67	case SCM_GSUBR_MAKTYPE(3, 0, 0):
9d78586f MV	68	subr = scm_c_make_subr (name, scm_tc7_subr_3, fcn);
e20d7001	69	break;
9d78586f MV	70	case SCM_GSUBR_MAKTYPE(0, 0, 1):
9d78586f MV	71	subr = scm_c_make_subr (name, scm_tc7_lsubr, fcn);
e20d7001	72	break;
9d78586f MV	73	case SCM_GSUBR_MAKTYPE(2, 0, 1):
9d78586f MV	74	subr = scm_c_make_subr (name, scm_tc7_lsubr_2, fcn);
e20d7001	75	break;
9d78586f MV	76	default:
9d78586f MV	77	{
e20d7001 LC	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);
9d78586f	88	}
0f2d19dd	89	}
e20d7001 LC	90
	91	if (define)
	92	scm_define (SCM_SNAME (subr), subr);
	93
	94	return subr;
0f2d19dd JB	95	}
0f2d19dd JB	96
9de33deb	97	SCM
9d78586f	98	scm_c_make_gsubr (const char name, int req, int opt, int rst, SCM (fcn)())
9de33deb	99	{
9d78586f MV	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)
cce8b2ce	147	scm_define (SCM_SNAME (subr), subr);
9d78586f MV	148	return subr;
	149	default:
	150	;
	151	}
	152	scm_misc_error ("scm_c_make_gsubr_with_generic",
9de33deb MD	153	"can't make primitive-generic with this arity",
9de33deb MD	154	SCM_EOL);
4260a7fc	155	return SCM_BOOL_F; /* never reached */
9de33deb MD	156	}
9de33deb MD	157
9d78586f MV	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
0f2d19dd	180
6fa73e72 GB	181	SCM
6fa73e72 GB	182	scm_gsubr_apply (SCM args)
a4bb4e6d	183	#define FUNC_NAME "scm_gsubr_apply"
0f2d19dd	184	{
1be6b49c	185	SCM self = SCM_CAR (args);
e20d7001	186	SCM (*fcn)() = SCM_SUBRF (self);
a4bb4e6d	187	SCM v[SCM_GSUBR_MAX];
e20d7001	188	unsigned int typ = SCM_GSUBR_TYPE (self);
c014a02e	189	long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ);
e20d7001	190
1be6b49c ML	191	args = SCM_CDR (args);
1be6b49c ML	192	for (i = 0; i < SCM_GSUBR_REQ (typ); i++) {
d2e53ed6	193	if (scm_is_null (args))
e20d7001	194	scm_wrong_num_args (SCM_SNAME (self));
0f2d19dd JB	195	v[i] = SCM_CAR(args);
	196	args = SCM_CDR(args);
	197	}
1be6b49c ML	198	for (; i < SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ); i++) {
	199	if (SCM_NIMP (args)) {
	200	v[i] = SCM_CAR (args);
0f2d19dd JB	201	args = SCM_CDR(args);
	202	}
	203	else
	204	v[i] = SCM_UNDEFINED;
	205	}
dc0938d8	206	if (SCM_GSUBR_REST(typ))
0f2d19dd	207	v[i] = args;
d2e53ed6	208	else if (!scm_is_null (args))
e20d7001	209	scm_wrong_num_args (SCM_SNAME (self));
0f2d19dd	210	switch (n) {
0f2d19dd JB	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]);
e20d7001 LC	220	default:
	221	scm_misc_error ((char *) SCM_SNAME (self),
	222	"gsubr invocation with more than 10 arguments not implemented",
	223	SCM_EOL);
0f2d19dd	224	}
4260a7fc	225	return SCM_BOOL_F; /* Never reached. */
0f2d19dd	226	}
a4bb4e6d	227	#undef FUNC_NAME
0f2d19dd JB	228
	229
	230	#ifdef GSUBR_TEST
	231	/* A silly example, taking 2 required args, 1 optional, and
c0fa6561	232	a scm_list of rest args
0f2d19dd JB	233	*/
0f2d19dd JB	234	SCM
1bbd0b84	235	gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst)
0f2d19dd	236	{
b7f3516f	237	scm_puts ("gsubr-2-1-l:\n req1: ", scm_cur_outp);
0f2d19dd	238	scm_display(req1, scm_cur_outp);
b7f3516f	239	scm_puts ("\n req2: ", scm_cur_outp);
0f2d19dd	240	scm_display(req2, scm_cur_outp);
b7f3516f	241	scm_puts ("\n opt: ", scm_cur_outp);
0f2d19dd	242	scm_display(opt, scm_cur_outp);
b7f3516f	243	scm_puts ("\n rest: ", scm_cur_outp);
0f2d19dd JB	244	scm_display(rst, scm_cur_outp);
	245	scm_newline(scm_cur_outp);
	246	return SCM_UNSPECIFIED;
	247	}
	248	#endif
	249
	250
0f2d19dd JB	251	void
0f2d19dd JB	252	scm_init_gsubr()
0f2d19dd	253	{
0f2d19dd	254	#ifdef GSUBR_TEST
9d78586f	255	scm_c_define_gsubr ("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */
0f2d19dd	256	#endif
85db4a2c	257
85db4a2c	258	#include "libguile/gsubr.x"
0f2d19dd	259	}
89e00824 ML	260
	261	/*
	262	Local Variables:
	263	c-file-style: "gnu"
	264	End:
	265	*/