/*
  gsubr.c
  Provide `gsubrs' -- subrs taking a prescribed number of required, optional,
  and rest arguments.
*/

#include "scm.h"

#define GSUBR_TEST 1

#define GSUBR_MAKTYPE(req, opt, rst) ((req)|((opt)<<4)|((rst)<<8))
#define GSUBR_REQ(x) ((int)(x)&0xf)
#define GSUBR_OPT(x) (((int)(x)&0xf0)>>4)
#define GSUBR_REST(x) ((int)(x)>>8)

#define GSUBR_MAX 10
#define GSUBR_TYPE(cclo) (VELTS(cclo)[1])
#define GSUBR_PROC(cclo) (VELTS(cclo)[2])

static SCM f_gsubr_apply;
SCM scm_make_gsubr(name, req, opt, rst, fcn)
     char *name;
     int req, opt, rst;
     SCM (*fcn)();
{
  switch GSUBR_MAKTYPE(req, opt, rst) {
  case GSUBR_MAKTYPE(0, 0, 0): return scm_make_subr(name, tc7_subr_0, fcn);
  case GSUBR_MAKTYPE(1, 0, 0): return scm_make_subr(name, tc7_subr_1, fcn);
  case GSUBR_MAKTYPE(0, 1, 0): return scm_make_subr(name, tc7_subr_1o, fcn);
  case GSUBR_MAKTYPE(1, 1, 0): return scm_make_subr(name, tc7_subr_2o, fcn);
  case GSUBR_MAKTYPE(2, 0, 0): return scm_make_subr(name, tc7_subr_2, fcn);
  case GSUBR_MAKTYPE(3, 0, 0): return scm_make_subr(name, tc7_subr_3, fcn);
  case GSUBR_MAKTYPE(0, 0, 1): return scm_make_subr(name, tc7_lsubr, fcn);
  case GSUBR_MAKTYPE(2, 0, 1): return scm_make_subr(name, tc7_lsubr_2, fcn);
  default:
    {
      SCM symcell = scm_sysintern(name, SCM_UNDEFINED);
      SCM z, cclo = scm_makcclo(f_gsubr_apply, 3L);
      long tmp = ((((CELLPTR)(CAR(symcell)))-scm_heap_org)<<8);
      if (GSUBR_MAX < req + opt + rst) {
	fputs("ERROR in scm_make_gsubr: too many args\n", stderr);
	scm_quit(MAKINUM(1L));
      }
      if ((tmp>>8) != ((CELLPTR)(CAR(symcell))-scm_heap_org))
	tmp = 0;
      NEWCELL(z);
      SUBRF(z) = fcn;
      CAR(z) = tmp + tc7_subr_0;
      GSUBR_PROC(cclo) = z;
      GSUBR_TYPE(cclo) = MAKINUM(GSUBR_MAKTYPE(req, opt, rst));
      CDR(symcell) = cclo;
      return cclo;
    }
  }
}

char s_gsubr_apply[] = " gsubr-apply";
SCM scm_gsubr_apply(args)
     SCM args;
{
  SCM self = CAR(args);
  SCM (*fcn)() = SUBRF(GSUBR_PROC(self));
  SCM argv, *v;
  int typ = INUM(GSUBR_TYPE(self));
  int i, n = GSUBR_REQ(typ) + GSUBR_OPT(typ) + GSUBR_REST(typ);
  argv = scm_make_vector(MAKINUM(n), SCM_UNDEFINED);
  v = VELTS(argv);
  args = CDR(args);
  for (i = 0; i < GSUBR_REQ(typ); i++) {
#ifndef RECKLESS
    if (IMP(args))
    wna: scm_wta(SCM_UNDEFINED, (char *)WNA, CHARS(SNAME(GSUBR_PROC(self))));
#endif
    v[i] = CAR(args);
    args = CDR(args);
  }
  for (; i < GSUBR_REQ(typ) + GSUBR_OPT(typ); i++) {
    if (NIMP(args)) {
      v[i] = CAR(args);
      args = CDR(args);
    }
    else
      v[i] = SCM_UNDEFINED;
  }
  if (GSUBR_REST(typ))
    v[i] = args;
  switch (n) {
  default: scm_wta(self, "internal programming error", s_gsubr_apply);
  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]);
  }
}


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

extern char scm_s_lvector_set[];
extern SCM scm_lvector_set();
extern SCM scm_f_lvector_set;
extern char scm_s_throw[];
extern SCM scm_throw();
extern char scm_s_throw_or_retry[];
extern SCM scm_throw_or_retry();
extern SCM scm_utime();
extern char scm_s_utime[];
extern SCM *scm_f_utime;

void scm_init_gsubr()
{
  f_gsubr_apply = scm_make_subr(s_gsubr_apply, tc7_lsubr, scm_gsubr_apply);
#ifdef GSUBR_TEST
  scm_make_gsubr("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */
#endif
  scm_f_lvector_set
    = scm_make_gsubr (scm_s_lvector_set, 4, 0, 0, scm_lvector_set);
  scm_make_gsubr (scm_s_throw, 1, 0, 1, scm_throw);
  scm_make_gsubr (scm_s_throw_or_retry, 1, 0, 1, scm_throw_or_retry);
}
