← Back to branch summary

~ubuntu-branches/ubuntu/intrepid/ecl/intrepid

« back to all changes in this revision

Viewing changes to src/c/gfun.d

  • Committer: Bazaar Package Importer
  • Author(s): Peter Van Eynde
  • Date: 2006-06-21 09:21:21 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20060621092121-txz1f21lj0wh0f67
Tags: 0.9h-20060617-1
* New upstream version
* Updated standards version without real changes. 

Show diffs side-by-side

added added

removed removed

Lines of Context:
src/c/gfun.d
12
12
    See file '../Copyright' for full details.
13
13
*/
14
14
 
 
15
#include <string.h>
15
16
#include <ecl/ecl.h>
16
17
#include <ecl/internal.h>
17
18
 
 
19
static void
 
20
reshape_instance(cl_object x, int delta)
 
21
{
 
22
        cl_fixnum size = x->instance.length + delta;
 
23
        cl_object aux = ecl_allocate_instance(CLASS_OF(x), size);
 
24
        memcpy(aux->instance.slots, x->instance.slots,
 
25
               (delta < 0 ? aux->instance.length : x->instance.length) *
 
26
               sizeof(cl_object));
 
27
        x->instance = aux->instance;
 
28
}
 
29
 
 
30
/* this turns any instance into a funcallable (apart from a builtin generic function)
 
31
   or back into an ordinary instance */
 
32
 
18
33
cl_object
19
 
si_set_funcallable(cl_object instance, cl_object flag)
 
34
si_set_raw_funcallable(cl_object instance, cl_object function)
20
35
{
21
36
        if (type_of(instance) != t_instance)
22
37
                FEwrong_type_argument(@'ext::instance', instance);
23
 
        instance->instance.isgf = !Null(flag);
 
38
        if (Null(function)) {
 
39
                if (instance->instance.isgf == 2) {
 
40
                        int        length          = instance->instance.length-1;
 
41
                        cl_object *slots           = (cl_object*)cl_alloc(sizeof(cl_object)*(length));
 
42
                        instance->instance.isgf    = 2;
 
43
                        memcpy(slots, instance->instance.slots, sizeof(cl_object)*(length));
 
44
                        instance->instance.slots   = slots;
 
45
                        instance->instance.length  = length;
 
46
                        instance->instance.isgf = 0;
 
47
                }
 
48
        } else  {
 
49
                if (instance->instance.isgf == 0) {
 
50
                        int        length          = instance->instance.length+1;
 
51
                        cl_object *slots           = (cl_object*)cl_alloc(sizeof(cl_object)*length);
 
52
                        memcpy(slots, instance->instance.slots, sizeof(cl_object)*(length-1));
 
53
                        instance->instance.slots   = slots;
 
54
                        instance->instance.length  = length;
 
55
                        instance->instance.isgf    = 2;
 
56
                }
 
57
                instance->instance.slots[instance->instance.length-1] = function;
 
58
        }
24
59
        @(return instance)
25
60
}
26
61
 
27
62
cl_object
28
 
si_generic_function_p(cl_object instance)
29
 
{
30
 
        @(return (((type_of(instance) != t_instance) &&
31
 
                   (instance->instance.isgf))? Ct : Cnil))
 
63
clos_set_funcallable_instance_function(cl_object x, cl_object function_or_t)
 
64
{
 
65
        if (type_of(x) != t_instance)
 
66
                FEwrong_type_argument(@'ext::instance', x);
 
67
        if (x->instance.isgf == ECL_USER_DISPATCH) {
 
68
                reshape_instance(x, -1);
 
69
                x->instance.isgf = ECL_NOT_FUNCALLABLE;
 
70
        }
 
71
        if (function_or_t == Ct)
 
72
        {
 
73
                x->instance.isgf = ECL_STANDARD_DISPATCH;
 
74
        } else if (function_or_t == Cnil) {
 
75
                x->instance.isgf = ECL_NOT_FUNCALLABLE;
 
76
        } else if (Null(cl_functionp(function_or_t))) {
 
77
                FEwrong_type_argument(@'function', function_or_t);
 
78
        } else {
 
79
                reshape_instance(x, +1);
 
80
                x->instance.slots[x->instance.length - 1] = function_or_t;
 
81
                x->instance.isgf = ECL_USER_DISPATCH;
 
82
        }
 
83
        @(return x)
 
84
}
 
85
 
 
86
cl_object
 
87
si_generic_function_p(cl_object x)
 
88
{
 
89
        @(return (((type_of(x) != t_instance) &&
 
90
                   (x->instance.isgf))? Ct : Cnil))
32
91
}
33
92
 
34
93
/*
92
151
        e->value = value;
93
152
}
94
153
 
95
 
cl_object
96
 
compute_method(cl_narg narg, cl_object gf, cl_object *args)
 
154
static cl_object
 
155
standard_dispatch(cl_narg narg, cl_object gf, cl_object *args)
97
156
{
98
 
        cl_object func;
99
157
        int i, spec_no;
100
158
        struct ecl_hashtable_entry *e;
101
159
        cl_object spec_how_list = GFUN_SPEC(gf);
102
160
        cl_object table = GFUN_HASH(gf);
103
 
#ifdef __GNUC__
104
 
        cl_object argtype[narg]; /* __GNUC__ */
105
 
#else
106
 
#define ARGTYPE_MAX 64
107
 
        cl_object argtype[ARGTYPE_MAX];
108
 
        if (narg > ARGTYPE_MAX)
109
 
          FEerror("compute_method: Too many arguments, limited to ~A.", 1, MAKE_FIXNUM(ARGTYPE_MAX));
110
 
#endif
 
161
        cl_object argtype[LAMBDA_PARAMETERS_LIMIT];
111
162
 
112
163
        for (spec_no = 0; spec_how_list != Cnil;) {
113
164
                cl_object spec_how = CAR(spec_how_list);
125
176
 
126
177
        e = get_meth_hash(argtype, spec_no, table);
127
178
 
128
 
        if (e->key == OBJNULL) {
 
179
        if (e->key != OBJNULL) {
 
180
                return e->value;
 
181
        } else {
129
182
                /* method not cached */
130
 
                cl_object methods, arglist;
 
183
                cl_object methods, arglist, func;
131
184
                for (i = narg, arglist = Cnil; i-- > 0; ) {
132
185
                        arglist = CONS(args[i], arglist);
133
186
                }
 
187
                
134
188
                methods = funcall(3, @'compute-applicable-methods', gf,
135
189
                                  arglist);
136
190
                if (methods == Cnil) {
137
 
                        VALUES(0) = funcall(3, @'no-applicable-method', gf,
138
 
                                            arglist);
139
 
                        return NULL;
 
191
                        func = funcall(3, @'no-applicable-method', gf,
 
192
                                       arglist);
 
193
                        args[0] = 0;
 
194
                        return func;
140
195
                }
141
196
                func = funcall(4, @'clos::compute-effective-method', gf,
142
197
                               GFUN_COMB(gf), methods);
143
198
                /* update cache */
144
199
                set_meth_hash(argtype, spec_no, table, func);
145
 
        } else {
146
 
                /* method is already cached */
147
 
                func = e->value;
148
 
        }
149
 
        return func;
 
200
                return func;
 
201
        }
 
202
}
 
203
 
 
204
cl_object
 
205
compute_method(cl_narg narg, cl_object gf, cl_object *args)
 
206
{
 
207
        switch (gf->instance.isgf) {
 
208
        case ECL_STANDARD_DISPATCH:
 
209
                return standard_dispatch(narg, gf, args);
 
210
        case ECL_USER_DISPATCH:
 
211
                return gf->instance.slots[gf->instance.length - 1];
 
212
        default:
 
213
                FEinvalid_function(gf);
 
214
        }
150
215
}
151
216
 
152
217
cl_object