← Back to branch summary

~peter-pearse/ubuntu/natty/guile-1.8/prop001

« back to all changes in this revision

Viewing changes to libguile/gsubr.c

  • Committer: Bazaar Package Importer
  • Author(s): Daniel Schepler
  • Date: 2006-11-09 03:11:16 UTC
  • Revision ID: james.westby@ubuntu.com-20061109031116-hu0q1jxqg12y6yeg
Tags: upstream-1.8.1+1
Import upstream version 1.8.1+1

Show diffs side-by-side

added added

removed removed

Lines of Context:
libguile/gsubr.c
 
1
/* Copyright (C) 1995,1996,1997,1998,1999,2000,2001, 2006 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
 
 
19
 
 
20
#include <stdio.h>
 
21
#include "libguile/_scm.h"
 
22
#include "libguile/procprop.h"
 
23
#include "libguile/root.h"
 
24
 
 
25
#include "libguile/gsubr.h"
 
26
#include "libguile/deprecation.h"
 
27
 
 
28
/*
 
29
 * gsubr.c
 
30
 * Provide `gsubrs' -- subrs taking a prescribed number of required, optional,
 
31
 * and rest arguments.
 
32
 */
 
33
 
 
34
/* #define GSUBR_TEST */
 
35
 
 
36
SCM_GLOBAL_SYMBOL (scm_sym_name, "name");
 
37
 
 
38
SCM scm_f_gsubr_apply;
 
39
 
 
40
static SCM
 
41
create_gsubr (int define, const char *name,
 
42
              int req, int opt, int rst, SCM (*fcn)())
 
43
{
 
44
  SCM subr;
 
45
 
 
46
  switch (SCM_GSUBR_MAKTYPE (req, opt, rst))
 
47
    {
 
48
    case SCM_GSUBR_MAKTYPE(0, 0, 0):
 
49
      subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn);
 
50
      goto create_subr;
 
51
    case SCM_GSUBR_MAKTYPE(1, 0, 0):
 
52
      subr = scm_c_make_subr (name, scm_tc7_subr_1, fcn);
 
53
      goto create_subr;
 
54
    case SCM_GSUBR_MAKTYPE(0, 1, 0):
 
55
      subr = scm_c_make_subr (name, scm_tc7_subr_1o, fcn);
 
56
      goto create_subr;
 
57
    case SCM_GSUBR_MAKTYPE(1, 1, 0):
 
58
      subr = scm_c_make_subr (name, scm_tc7_subr_2o, fcn);
 
59
      goto create_subr;
 
60
    case SCM_GSUBR_MAKTYPE(2, 0, 0):
 
61
      subr = scm_c_make_subr (name, scm_tc7_subr_2, fcn);
 
62
      goto create_subr;
 
63
    case SCM_GSUBR_MAKTYPE(3, 0, 0):
 
64
      subr = scm_c_make_subr (name, scm_tc7_subr_3, fcn);
 
65
      goto create_subr;
 
66
    case SCM_GSUBR_MAKTYPE(0, 0, 1):
 
67
      subr = scm_c_make_subr (name, scm_tc7_lsubr, fcn);
 
68
      goto create_subr;
 
69
    case SCM_GSUBR_MAKTYPE(2, 0, 1):
 
70
      subr = scm_c_make_subr (name, scm_tc7_lsubr_2, fcn);
 
71
    create_subr:
 
72
      if (define)
 
73
        scm_define (SCM_SUBR_ENTRY(subr).name, subr);
 
74
      return subr;
 
75
    default:
 
76
      {
 
77
        SCM cclo = scm_makcclo (scm_f_gsubr_apply, 3L);
 
78
        SCM subr = scm_c_make_subr (name, scm_tc7_subr_0, fcn);
 
79
        SCM sym = SCM_SUBR_ENTRY(subr).name;
 
80
        if (SCM_GSUBR_MAX < req + opt + rst)
 
81
          {
 
82
            fprintf (stderr,
 
83
                     "ERROR in scm_c_make_gsubr: too many args (%d) to %s\n",
 
84
                     req + opt + rst, name);
 
85
            exit (1);
 
86
          }
 
87
        SCM_SET_GSUBR_PROC (cclo, subr);
 
88
        SCM_SET_GSUBR_TYPE (cclo,
 
89
                            scm_from_int (SCM_GSUBR_MAKTYPE (req, opt, rst)));
 
90
        if (SCM_REC_PROCNAMES_P)
 
91
          scm_set_procedure_property_x (cclo, scm_sym_name, sym);
 
92
        if (define)
 
93
          scm_define (sym, cclo);
 
94
      return cclo;
 
95
      }
 
96
    }
 
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_SUBR_ENTRY(subr).name, 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
 
 
183
SCM
 
184
scm_gsubr_apply (SCM args)
 
185
#define FUNC_NAME "scm_gsubr_apply"
 
186
{
 
187
  SCM self = SCM_CAR (args);
 
188
  SCM (*fcn)() = SCM_SUBRF (SCM_GSUBR_PROC (self));
 
189
  SCM v[SCM_GSUBR_MAX];
 
190
  int typ = scm_to_int (SCM_GSUBR_TYPE (self));
 
191
  long i, n = SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ) + SCM_GSUBR_REST (typ);
 
192
#if 0
 
193
  if (n > SCM_GSUBR_MAX)
 
194
    scm_misc_error (FUNC_NAME,
 
195
                    "Function ~S has illegal arity ~S.",
 
196
                    scm_list_2 (self, scm_from_int (n)));
 
197
#endif
 
198
  args = SCM_CDR (args);
 
199
  for (i = 0; i < SCM_GSUBR_REQ (typ); i++) {
 
200
    if (scm_is_null (args))
 
201
      scm_wrong_num_args (SCM_SNAME (SCM_GSUBR_PROC (self)));
 
202
    v[i] = SCM_CAR(args);
 
203
    args = SCM_CDR(args);
 
204
  }
 
205
  for (; i < SCM_GSUBR_REQ (typ) + SCM_GSUBR_OPT (typ); i++) {
 
206
    if (SCM_NIMP (args)) {
 
207
      v[i] = SCM_CAR (args);
 
208
      args = SCM_CDR(args);
 
209
    }
 
210
    else
 
211
      v[i] = SCM_UNDEFINED;
 
212
  }
 
213
  if (SCM_GSUBR_REST(typ))
 
214
    v[i] = args;
 
215
  else if (!scm_is_null (args))
 
216
    scm_wrong_num_args (SCM_SNAME (SCM_GSUBR_PROC (self)));
 
217
  switch (n) {
 
218
  case 2: return (*fcn)(v[0], v[1]);
 
219
  case 3: return (*fcn)(v[0], v[1], v[2]);
 
220
  case 4: return (*fcn)(v[0], v[1], v[2], v[3]);
 
221
  case 5: return (*fcn)(v[0], v[1], v[2], v[3], v[4]);
 
222
  case 6: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5]);
 
223
  case 7: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6]);
 
224
  case 8: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7]);
 
225
  case 9: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8]);
 
226
  case 10: return (*fcn)(v[0], v[1], v[2], v[3], v[4], v[5], v[6], v[7], v[8], v[9]);
 
227
  }
 
228
  return SCM_BOOL_F; /* Never reached. */
 
229
}
 
230
#undef FUNC_NAME
 
231
 
 
232
 
 
233
#ifdef GSUBR_TEST
 
234
/* A silly example, taking 2 required args, 1 optional, and
 
235
   a scm_list of rest args
 
236
   */
 
237
SCM
 
238
gsubr_21l(SCM req1, SCM req2, SCM opt, SCM rst)
 
239
{
 
240
  scm_puts ("gsubr-2-1-l:\n req1: ", scm_cur_outp);
 
241
  scm_display(req1, scm_cur_outp);
 
242
  scm_puts ("\n req2: ", scm_cur_outp);
 
243
  scm_display(req2, scm_cur_outp);
 
244
  scm_puts ("\n opt: ", scm_cur_outp);
 
245
  scm_display(opt, scm_cur_outp);
 
246
  scm_puts ("\n rest: ", scm_cur_outp);
 
247
  scm_display(rst, scm_cur_outp);
 
248
  scm_newline(scm_cur_outp);
 
249
  return SCM_UNSPECIFIED;
 
250
}
 
251
#endif
 
252
 
 
253
 
 
254
void
 
255
scm_init_gsubr()
 
256
{
 
257
  scm_f_gsubr_apply = scm_c_make_subr ("gsubr-apply", scm_tc7_lsubr,
 
258
                                       scm_gsubr_apply);
 
259
#ifdef GSUBR_TEST
 
260
  scm_c_define_gsubr ("gsubr-2-1-l", 2, 1, 1, gsubr_21l); /* example */
 
261
#endif
 
262
 
 
263
#include "libguile/gsubr.x"
 
264
}
 
265
 
 
266
/*
 
267
  Local Variables:
 
268
  c-file-style: "gnu"
 
269
  End:
 
270
*/