[e90b2f]: src / c / gfun.d Maximize Restore History

Download this file

gfun.d    300 lines (278 with data), 9.5 kB

  1
  2
  3
  4
  5
  6
  7
  8
  9
 10
 11
 12
 13
 14
 15
 16
 17
 18
 19
 20
 21
 22
 23
 24
 25
 26
 27
 28
 29
 30
 31
 32
 33
 34
 35
 36
 37
 38
 39
 40
 41
 42
 43
 44
 45
 46
 47
 48
 49
 50
 51
 52
 53
 54
 55
 56
 57
 58
 59
 60
 61
 62
 63
 64
 65
 66
 67
 68
 69
 70
 71
 72
 73
 74
 75
 76
 77
 78
 79
 80
 81
 82
 83
 84
 85
 86
 87
 88
 89
 90
 91
 92
 93
 94
 95
 96
 97
 98
 99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
/* -*- mode: c; c-basic-offset: 8 -*- */
/*
gfun.c -- Dispatch for generic functions.
*/
/*
Copyright (c) 1990, Giuseppe Attardi.
ECL is free software; you can redistribute it and/or
modify it under the terms of the GNU Library General Public
License as published by the Free Software Foundation; either
version 2 of the License, or (at your option) any later version.
See file '../Copyright' for full details.
*/
#include <string.h>
#include <ecl/ecl.h>
#include <ecl/ecl-inl.h>
#include <ecl/internal.h>
#include <ecl/cache.h>
static cl_object generic_function_dispatch_vararg(cl_narg, ...);
cl_object
FEnot_funcallable_fixed()
{
cl_env_ptr env = ecl_process_env();
cl_object fun = env->function;
FEerror("Not a funcallable instance ~A.", 1, fun);
@(return);
}
cl_object
FEnot_funcallable_vararg(cl_narg narg, ...)
{
return FEnot_funcallable_fixed();
}
static cl_object
user_function_dispatch(cl_narg narg, ...)
{
int i;
cl_object output;
cl_env_ptr env = ecl_process_env();
cl_object fun = env->function;
struct ecl_stack_frame frame_aux;
const cl_object frame = ecl_stack_frame_open(env, (cl_object)&frame_aux, narg);
ecl_va_list args; ecl_va_start(args, narg, narg, 0);
for (i = 0; i < narg; i++) {
ECL_STACK_FRAME_SET(frame, i, ecl_va_arg(args));
}
fun = fun->instance.slots[fun->instance.length - 1];
output = ecl_apply_from_stack_frame(frame, fun);
ecl_stack_frame_close(frame);
return output;
}
static void
reshape_instance(cl_object x, int delta)
{
cl_fixnum size = x->instance.length + delta;
cl_object aux = ecl_allocate_instance(ECL_CLASS_OF(x), size);
/* Except for the different size, this must match si_copy_instance */
aux->instance.sig = x->instance.sig;
memcpy(aux->instance.slots, x->instance.slots,
(delta < 0 ? aux->instance.length : x->instance.length) *
sizeof(cl_object));
x->instance = aux->instance;
}
cl_object
clos_set_funcallable_instance_function(cl_object x, cl_object function_or_t)
{
if (ecl_unlikely(!ECL_INSTANCEP(x)))
FEwrong_type_nth_arg(@[clos::set-funcallable-instance-function],
1, x, @[ext::instance]);
if (x->instance.isgf == ECL_USER_DISPATCH) {
reshape_instance(x, -1);
x->instance.isgf = ECL_NOT_FUNCALLABLE;
}
if (function_or_t == ECL_T) {
x->instance.isgf = ECL_STANDARD_DISPATCH;
x->instance.entry = generic_function_dispatch_vararg;
} else if (function_or_t == @'standard-generic-function') {
x->instance.isgf = ECL_RESTRICTED_DISPATCH;
x->instance.entry = generic_function_dispatch_vararg;
} else if (function_or_t == ECL_NIL) {
x->instance.isgf = ECL_NOT_FUNCALLABLE;
x->instance.entry = FEnot_funcallable_vararg;
} else if (function_or_t == @'clos::standard-reader-method') {
/* WARNING: We assume that f(a,...) behaves as f(a,b) */
x->instance.isgf = ECL_READER_DISPATCH;
x->instance.entry = (cl_objectfn)ecl_slot_reader_dispatch;
} else if (function_or_t == @'clos::standard-writer-method') {
/* WARNING: We assume that f(a,...) behaves as f(a,b) */
x->instance.isgf = ECL_WRITER_DISPATCH;
x->instance.entry = (cl_objectfn)ecl_slot_writer_dispatch;
} else if (Null(cl_functionp(function_or_t))) {
FEwrong_type_argument(@'function', function_or_t);
} else {
reshape_instance(x, +1);
x->instance.slots[x->instance.length - 1] = function_or_t;
x->instance.isgf = ECL_USER_DISPATCH;
x->instance.entry = user_function_dispatch;
}
@(return x)
}
cl_object
si_generic_function_p(cl_object x)
{
@(return ((ECL_INSTANCEP(x) && (x->instance.isgf))? ECL_T : ECL_NIL))
}
static cl_object
fill_spec_vector(cl_object vector, cl_object frame, cl_object gf)
{
cl_object *args = frame->frame.base;
cl_index narg = frame->frame.size;
cl_object spec_how_list = GFUN_SPEC(gf);
cl_object *argtype = vector->vector.self.t;
int spec_no = 1;
argtype[0] = gf;
loop_for_on_unsafe(spec_how_list) {
cl_object spec_how = ECL_CONS_CAR(spec_how_list);
cl_object spec_type = ECL_CONS_CAR(spec_how);
int spec_position = ecl_fixnum(ECL_CONS_CDR(spec_how));
unlikely_if (spec_position >= narg)
FEwrong_num_arguments(gf);
unlikely_if (spec_no >= vector->vector.dim)
ecl_internal_error("Too many arguments to fill_spec_vector()");
argtype[spec_no++] =
(!ECL_LISTP(spec_type) ||
Null(ecl_memql(args[spec_position], spec_type))) ?
cl_class_of(args[spec_position]) :
args[spec_position];
} end_loop_for_on_unsafe(spec_how_list);
vector->vector.fillp = spec_no;
return vector;
}
static cl_object
frame_to_list(cl_object frame)
{
cl_object arglist, *p;
for (p = frame->frame.base + frame->frame.size, arglist = ECL_NIL;
p != frame->frame.base; ) {
arglist = CONS(*(--p), arglist);
}
return arglist;
}
static cl_object
frame_to_classes(cl_object frame)
{
cl_object arglist, *p;
for (p = frame->frame.base + frame->frame.size, arglist = ECL_NIL;
p != frame->frame.base; ) {
arglist = CONS(cl_class_of(*(--p)), arglist);
}
return arglist;
}
static cl_object
generic_compute_applicable_method(cl_env_ptr env, cl_object frame, cl_object gf)
{
/* method not cached */
cl_object memoize;
cl_object methods = _ecl_funcall3(@'clos::compute-applicable-methods-using-classes',
gf, frame_to_classes(frame));
unlikely_if (Null(memoize = env->values[1])) {
cl_object arglist = frame_to_list(frame);
methods = _ecl_funcall3(@'compute-applicable-methods',
gf, arglist);
unlikely_if (methods == ECL_NIL) {
cl_object func = _ecl_funcall3(@'no-applicable-method',
gf, arglist);
frame->frame.base[0] = OBJNULL;
env->values[1] = ECL_NIL;
return func;
}
}
methods = clos_compute_effective_method_function(gf, GFUN_COMB(gf), methods);
env->values[1] = ECL_T;
return methods;
}
static cl_object
restricted_compute_applicable_method(cl_env_ptr env, cl_object frame, cl_object gf)
{
/* method not cached */
cl_object arglist = frame_to_list(frame);
cl_object methods = clos_std_compute_applicable_methods(gf, arglist);
unlikely_if (methods == ECL_NIL) {
cl_object func = _ecl_funcall3(@'no-applicable-method', gf, arglist);
frame->frame.base[0] = OBJNULL;
env->values[1] = ECL_NIL;
return func;
}
methods = clos_std_compute_effective_method(gf, GFUN_COMB(gf), methods);
env->values[1] = ECL_T;
return methods;
}
static cl_object
compute_applicable_method(cl_env_ptr env, cl_object frame, cl_object gf)
{
if (gf->instance.isgf == ECL_RESTRICTED_DISPATCH)
return restricted_compute_applicable_method(env, frame, gf);
else
return generic_compute_applicable_method(env, frame, gf);
}
cl_object
_ecl_standard_dispatch(cl_object frame, cl_object gf)
{
cl_object func, vector;
const cl_env_ptr env = frame->frame.env;
ecl_cache_ptr cache = env->method_cache;
ecl_cache_record_ptr e;
/*
* We have to copy the frame because it might be stored in cl_env.values
* which will be wiped out by the next function call. However this only
* happens when we cannot reuse the values in the C stack.
*/
#if !defined(ECL_USE_VARARG_AS_POINTER)
struct ecl_stack_frame frame_aux;
if (frame->frame.stack == (void*)0x1) {
const cl_object new_frame = (cl_object)&frame_aux;
ECL_STACK_FRAME_COPY(new_frame, frame);
frame = new_frame;
}
#endif
vector = fill_spec_vector(cache->keys, frame, gf);
e = ecl_search_cache(cache);
if (e->key != OBJNULL) {
func = e->value;
} else {
/* The keys and the cache may change while we
* compute the applicable methods. We must save
* the keys and recompute the cache location if
* it was filled. */
func = compute_applicable_method(env, frame, gf);
if (env->values[1] != ECL_NIL) {
cl_object keys = cl_copy_seq(vector);
if (e->key != OBJNULL) {
e = ecl_search_cache(cache);
}
e->key = keys;
e->value = func;
}
}
func = _ecl_funcall3(func, frame, ECL_NIL);
/* Only need to close the copy */
#if !defined(ECL_USE_VARARG_AS_POINTER)
if (frame == (cl_object)&frame_aux)
ecl_stack_frame_close(frame);
#endif
return func;
}
static cl_object
generic_function_dispatch_vararg(cl_narg narg, ...)
{
cl_object output;
ECL_STACK_FRAME_VARARGS_BEGIN(narg, narg, frame) {
output = _ecl_standard_dispatch(frame, frame->frame.env->function);
} ECL_STACK_FRAME_VARARGS_END(frame);
return output;
}
cl_object
si_clear_gfun_hash(cl_object what)
{
/*
* This function clears the generic function call hashes selectively.
* what = ECL_T means clear the hash completely
* what = generic function, means cleans only these entries
* If we work on a multithreaded environment, we simply enqueue these
* operations and wait for the destination thread to update its own hash.
*/
cl_env_ptr the_env = ecl_process_env();
#ifdef ECL_THREADS
cl_object list;
for (list = mp_all_processes(); !Null(list); list = ECL_CONS_CDR(list)) {
cl_object process = ECL_CONS_CAR(list);
struct cl_env_struct *env = process->process.env;
if (the_env != env) {
ecl_cache_remove_one(env->method_cache, what);
ecl_cache_remove_one(env->slot_cache, what);
}
}
#endif
ecl_cache_remove_one(the_env->method_cache, what);
ecl_cache_remove_one(the_env->slot_cache, what);
ecl_return0(the_env);
}