Deprecate C exports of GOOPS classes.
[bpt/guile.git] / libguile / deprecated.c
1 /* This file contains definitions for deprecated features. When you
2 deprecate something, move it here when that is feasible.
3 */
4
5 /* Copyright (C) 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
6 *
7 * This library is free software; you can redistribute it and/or
8 * modify it under the terms of the GNU Lesser General Public License
9 * as published by the Free Software Foundation; either version 3 of
10 * the License, or (at your option) any later version.
11 *
12 * This library is distributed in the hope that it will be useful, but
13 * WITHOUT ANY WARRANTY; without even the implied warranty of
14 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
15 * Lesser General Public License for more details.
16 *
17 * You should have received a copy of the GNU Lesser General Public
18 * License along with this library; if not, write to the Free Software
19 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
20 * 02110-1301 USA
21 */
22
23 #ifdef HAVE_CONFIG_H
24 # include <config.h>
25 #endif
26
27 #define SCM_BUILDING_DEPRECATED_CODE
28
29 #include "libguile/_scm.h"
30 #include "libguile/deprecation.h"
31
32 #if (SCM_ENABLE_DEPRECATED == 1)
33
34 \f
35
36 SCM
37 scm_internal_dynamic_wind (scm_t_guard before,
38 scm_t_inner inner,
39 scm_t_guard after,
40 void *inner_data,
41 void *guard_data)
42 {
43 SCM ans;
44
45 scm_c_issue_deprecation_warning
46 ("`scm_internal_dynamic_wind' is deprecated. "
47 "Use the `scm_dynwind_begin' / `scm_dynwind_end' API instead.");
48
49 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
50 scm_dynwind_rewind_handler (before, guard_data, SCM_F_WIND_EXPLICITLY);
51 scm_dynwind_unwind_handler (after, guard_data, SCM_F_WIND_EXPLICITLY);
52 ans = inner (inner_data);
53 scm_dynwind_end ();
54 return ans;
55 }
56
57 \f
58
59 SCM
60 scm_immutable_cell (scm_t_bits car, scm_t_bits cdr)
61 {
62 scm_c_issue_deprecation_warning
63 ("scm_immutable_cell is deprecated. Use scm_cell instead.");
64
65 return scm_cell (car, cdr);
66 }
67
68 SCM
69 scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
70 scm_t_bits ccr, scm_t_bits cdr)
71 {
72 scm_c_issue_deprecation_warning
73 ("scm_immutable_double_cell is deprecated. Use scm_double_cell instead.");
74
75 return scm_double_cell (car, cbr, ccr, cdr);
76 }
77
78
79 \f
80
81 SCM_GLOBAL_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
82 void
83 scm_memory_error (const char *subr)
84 {
85 scm_c_issue_deprecation_warning
86 ("scm_memory_error is deprecated. Use scm_report_out_of_memory to raise "
87 "an exception, or abort() to cause the program to exit.");
88
89 fprintf (stderr, "FATAL: memory error in %s\n", subr);
90 abort ();
91 }
92
93
94 \f
95
96 SCM scm_no_applicable_method = SCM_BOOL_F;
97
98 SCM scm_class_boolean, scm_class_char, scm_class_pair;
99 SCM scm_class_procedure, scm_class_string, scm_class_symbol;
100 SCM scm_class_primitive_generic;
101 SCM scm_class_vector, scm_class_null;
102 SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction;
103 SCM scm_class_unknown;
104 SCM scm_class_top, scm_class_object, scm_class_class;
105 SCM scm_class_applicable;
106 SCM scm_class_applicable_struct, scm_class_applicable_struct_with_setter;
107 SCM scm_class_generic, scm_class_generic_with_setter;
108 SCM scm_class_accessor;
109 SCM scm_class_extended_generic, scm_class_extended_generic_with_setter;
110 SCM scm_class_extended_accessor;
111 SCM scm_class_method;
112 SCM scm_class_accessor_method;
113 SCM scm_class_procedure_class;
114 SCM scm_class_applicable_struct_class;
115 SCM scm_class_number, scm_class_list;
116 SCM scm_class_keyword;
117 SCM scm_class_port, scm_class_input_output_port;
118 SCM scm_class_input_port, scm_class_output_port;
119 SCM scm_class_foreign_slot;
120 SCM scm_class_self, scm_class_protected;
121 SCM scm_class_hidden, scm_class_opaque, scm_class_read_only;
122 SCM scm_class_protected_hidden, scm_class_protected_opaque, scm_class_protected_read_only;
123 SCM scm_class_scm;
124 SCM scm_class_int, scm_class_float, scm_class_double;
125
126 SCM *scm_port_class, *scm_smob_class;
127
128 void
129 scm_init_deprecated_goops (void)
130 {
131 scm_no_applicable_method =
132 scm_variable_ref (scm_c_lookup ("no-applicable-method"));
133
134 scm_class_class = scm_variable_ref (scm_c_lookup ("<class>"));
135 scm_class_top = scm_variable_ref (scm_c_lookup ("<top>"));
136 scm_class_object = scm_variable_ref (scm_c_lookup ("<object>"));
137
138 scm_class_foreign_slot = scm_variable_ref (scm_c_lookup ("<foreign-slot>"));
139 scm_class_protected = scm_variable_ref (scm_c_lookup ("<protected-slot>"));
140 scm_class_hidden = scm_variable_ref (scm_c_lookup ("<hidden-slot>"));
141 scm_class_opaque = scm_variable_ref (scm_c_lookup ("<opaque-slot>"));
142 scm_class_read_only = scm_variable_ref (scm_c_lookup ("<read-only-slot>"));
143 scm_class_self = scm_variable_ref (scm_c_lookup ("<self-slot>"));
144 scm_class_protected_opaque = scm_variable_ref (scm_c_lookup ("<protected-opaque-slot>"));
145 scm_class_protected_hidden = scm_variable_ref (scm_c_lookup ("<protected-hidden-slot>"));
146 scm_class_protected_read_only = scm_variable_ref (scm_c_lookup ("<protected-read-only-slot>"));
147 scm_class_scm = scm_variable_ref (scm_c_lookup ("<scm-slot>"));
148 scm_class_int = scm_variable_ref (scm_c_lookup ("<int-slot>"));
149 scm_class_float = scm_variable_ref (scm_c_lookup ("<float-slot>"));
150 scm_class_double = scm_variable_ref (scm_c_lookup ("<double-slot>"));
151
152 /* scm_class_generic functions classes */
153 scm_class_procedure_class = scm_variable_ref (scm_c_lookup ("<procedure-class>"));
154 scm_class_applicable_struct_class = scm_variable_ref (scm_c_lookup ("<applicable-struct-class>"));
155
156 scm_class_method = scm_variable_ref (scm_c_lookup ("<method>"));
157 scm_class_accessor_method = scm_variable_ref (scm_c_lookup ("<accessor-method>"));
158 scm_class_applicable = scm_variable_ref (scm_c_lookup ("<applicable>"));
159 scm_class_applicable_struct = scm_variable_ref (scm_c_lookup ("<applicable-struct>"));
160 scm_class_applicable_struct_with_setter = scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter>"));
161 scm_class_generic = scm_variable_ref (scm_c_lookup ("<generic>"));
162 scm_class_extended_generic = scm_variable_ref (scm_c_lookup ("<extended-generic>"));
163 scm_class_generic_with_setter = scm_variable_ref (scm_c_lookup ("<generic-with-setter>"));
164 scm_class_accessor = scm_variable_ref (scm_c_lookup ("<accessor>"));
165 scm_class_extended_generic_with_setter = scm_variable_ref (scm_c_lookup ("<extended-generic-with-setter>"));
166 scm_class_extended_accessor = scm_variable_ref (scm_c_lookup ("<extended-accessor>"));
167
168 /* Primitive types classes */
169 scm_class_boolean = scm_variable_ref (scm_c_lookup ("<boolean>"));
170 scm_class_char = scm_variable_ref (scm_c_lookup ("<char>"));
171 scm_class_list = scm_variable_ref (scm_c_lookup ("<list>"));
172 scm_class_pair = scm_variable_ref (scm_c_lookup ("<pair>"));
173 scm_class_null = scm_variable_ref (scm_c_lookup ("<null>"));
174 scm_class_string = scm_variable_ref (scm_c_lookup ("<string>"));
175 scm_class_symbol = scm_variable_ref (scm_c_lookup ("<symbol>"));
176 scm_class_vector = scm_variable_ref (scm_c_lookup ("<vector>"));
177 scm_class_number = scm_variable_ref (scm_c_lookup ("<number>"));
178 scm_class_complex = scm_variable_ref (scm_c_lookup ("<complex>"));
179 scm_class_real = scm_variable_ref (scm_c_lookup ("<real>"));
180 scm_class_integer = scm_variable_ref (scm_c_lookup ("<integer>"));
181 scm_class_fraction = scm_variable_ref (scm_c_lookup ("<fraction>"));
182 scm_class_keyword = scm_variable_ref (scm_c_lookup ("<keyword>"));
183 scm_class_unknown = scm_variable_ref (scm_c_lookup ("<unknown>"));
184 scm_class_procedure = scm_variable_ref (scm_c_lookup ("<procedure>"));
185 scm_class_primitive_generic = scm_variable_ref (scm_c_lookup ("<primitive-generic>"));
186 scm_class_port = scm_variable_ref (scm_c_lookup ("<port>"));
187 scm_class_input_port = scm_variable_ref (scm_c_lookup ("<input-port>"));
188 scm_class_output_port = scm_variable_ref (scm_c_lookup ("<output-port>"));
189 scm_class_input_output_port = scm_variable_ref (scm_c_lookup ("<input-output-port>"));
190
191 scm_port_class = scm_i_port_class;
192 scm_smob_class = scm_i_smob_class;
193 }
194
195 #define BUFFSIZE 32 /* big enough for most uses */
196 #define SPEC_OF(x) \
197 (scm_slot_ref (x, scm_slot_ref (x, scm_from_latin1_symbol ("specializers"))))
198 #define CPL_OF(x) \
199 (scm_slot_ref (x, scm_slot_ref (x, scm_from_latin1_symbol ("cpl"))))
200
201 static SCM
202 scm_i_vector2list (SCM l, long len)
203 {
204 long j;
205 SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
206
207 for (j = 0; j < len; j++, l = SCM_CDR (l)) {
208 SCM_SIMPLE_VECTOR_SET (z, j, SCM_CAR (l));
209 }
210 return z;
211 }
212
213 static int
214 applicablep (SCM actual, SCM formal)
215 {
216 /* We already know that the cpl is well formed. */
217 return scm_is_true (scm_c_memq (formal, CPL_OF (actual)));
218 }
219
220 static int
221 more_specificp (SCM m1, SCM m2, SCM const *targs)
222 {
223 register SCM s1, s2;
224 register long i;
225 /*
226 * Note:
227 * m1 and m2 can have != length (i.e. one can be one element longer than the
228 * other when we have a dotted parameter list). For instance, with the call
229 * (M 1)
230 * with
231 * (define-method M (a . l) ....)
232 * (define-method M (a) ....)
233 *
234 * we consider that the second method is more specific.
235 *
236 * BTW, targs is an array of types. We don't need it's size since
237 * we already know that m1 and m2 are applicable (no risk to go past
238 * the end of this array).
239 *
240 */
241 for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) {
242 if (scm_is_null(s1)) return 1;
243 if (scm_is_null(s2)) return 0;
244 if (!scm_is_eq (SCM_CAR(s1), SCM_CAR(s2))) {
245 register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
246
247 for (l = CPL_OF (targs[i]); ; l = SCM_CDR(l)) {
248 if (scm_is_eq (cs1, SCM_CAR (l)))
249 return 1;
250 if (scm_is_eq (cs2, SCM_CAR (l)))
251 return 0;
252 }
253 return 0;/* should not occur! */
254 }
255 }
256 return 0; /* should not occur! */
257 }
258
259 static SCM
260 sort_applicable_methods (SCM method_list, long size, SCM const *targs)
261 {
262 long i, j, incr;
263 SCM *v, vector = SCM_EOL;
264 SCM buffer[BUFFSIZE];
265 SCM save = method_list;
266 scm_t_array_handle handle;
267
268 /* For reasonably sized method_lists we can try to avoid all the
269 * consing and reorder the list in place...
270 * This idea is due to David McClain <Dave_McClain@msn.com>
271 */
272 if (size <= BUFFSIZE)
273 {
274 for (i = 0; i < size; i++)
275 {
276 buffer[i] = SCM_CAR (method_list);
277 method_list = SCM_CDR (method_list);
278 }
279 v = buffer;
280 }
281 else
282 {
283 /* Too many elements in method_list to keep everything locally */
284 vector = scm_i_vector2list (save, size);
285 v = scm_vector_writable_elements (vector, &handle, NULL, NULL);
286 }
287
288 /* Use a simple shell sort since it is generally faster than qsort on
289 * small vectors (which is probably mostly the case when we have to
290 * sort a list of applicable methods).
291 */
292 for (incr = size / 2; incr; incr /= 2)
293 {
294 for (i = incr; i < size; i++)
295 {
296 for (j = i - incr; j >= 0; j -= incr)
297 {
298 if (more_specificp (v[j], v[j+incr], targs))
299 break;
300 else
301 {
302 SCM tmp = v[j + incr];
303 v[j + incr] = v[j];
304 v[j] = tmp;
305 }
306 }
307 }
308 }
309
310 if (size <= BUFFSIZE)
311 {
312 /* We did it in locally, so restore the original list (reordered) in-place */
313 for (i = 0, method_list = save; i < size; i++, v++)
314 {
315 SCM_SETCAR (method_list, *v);
316 method_list = SCM_CDR (method_list);
317 }
318 return save;
319 }
320
321 /* If we are here, that's that we did it the hard way... */
322 scm_array_handle_release (&handle);
323 return scm_vector_to_list (vector);
324 }
325
326 SCM
327 scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
328 {
329 register long i;
330 long count = 0;
331 SCM l, fl, applicable = SCM_EOL;
332 SCM save = args;
333 SCM buffer[BUFFSIZE];
334 SCM const *types;
335 SCM *p;
336 SCM tmp = SCM_EOL;
337 scm_t_array_handle handle;
338
339 scm_c_issue_deprecation_warning
340 ("scm_compute_applicable_methods is deprecated. Use "
341 "`compute-applicable-methods' from Scheme instead.");
342
343 /* Build the list of arguments types */
344 if (len >= BUFFSIZE)
345 {
346 tmp = scm_c_make_vector (len, SCM_UNDEFINED);
347 types = p = scm_vector_writable_elements (tmp, &handle, NULL, NULL);
348
349 /*
350 note that we don't have to work to reset the generation
351 count. TMP is a new vector anyway, and it is found
352 conservatively.
353 */
354 }
355 else
356 types = p = buffer;
357
358 for ( ; !scm_is_null (args); args = SCM_CDR (args))
359 *p++ = scm_class_of (SCM_CAR (args));
360
361 /* Build a list of all applicable methods */
362 for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
363 {
364 fl = SPEC_OF (SCM_CAR (l));
365 for (i = 0; ; i++, fl = SCM_CDR (fl))
366 {
367 if (SCM_INSTANCEP (fl)
368 /* We have a dotted argument list */
369 || (i >= len && scm_is_null (fl)))
370 { /* both list exhausted */
371 applicable = scm_cons (SCM_CAR (l), applicable);
372 count += 1;
373 break;
374 }
375 if (i >= len
376 || scm_is_null (fl)
377 || !applicablep (types[i], SCM_CAR (fl)))
378 break;
379 }
380 }
381
382 if (len >= BUFFSIZE)
383 scm_array_handle_release (&handle);
384
385 if (count == 0)
386 {
387 if (find_method_p)
388 return SCM_BOOL_F;
389 scm_call_2 (scm_no_applicable_method, gf, save);
390 /* if we are here, it's because no-applicable-method hasn't signaled an error */
391 return SCM_BOOL_F;
392 }
393
394 return (count == 1
395 ? applicable
396 : sort_applicable_methods (applicable, count, types));
397 }
398
399 SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
400
401 SCM
402 scm_find_method (SCM l)
403 #define FUNC_NAME "find-method"
404 {
405 SCM gf;
406 long len = scm_ilength (l);
407
408 if (len == 0)
409 SCM_WRONG_NUM_ARGS ();
410
411 scm_c_issue_deprecation_warning
412 ("scm_find_method is deprecated. Use `compute-applicable-methods' "
413 "from Scheme instead.");
414
415 gf = SCM_CAR(l); l = SCM_CDR(l);
416 SCM_VALIDATE_GENERIC (1, gf);
417 if (scm_is_null (scm_slot_ref (gf, scm_from_latin1_symbol ("methods"))))
418 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf));
419
420 return scm_compute_applicable_methods (gf, l, len - 1, 1);
421 }
422 #undef FUNC_NAME
423
424 SCM
425 scm_basic_make_class (SCM meta, SCM name, SCM dsupers, SCM dslots)
426 {
427 scm_c_issue_deprecation_warning
428 ("scm_basic_make_class is deprecated. Use `define-class' in Scheme,"
429 "or use `(make META #:name NAME #:dsupers DSUPERS #:slots DSLOTS)' "
430 "in Scheme.");
431
432 return scm_make_standard_class (meta, name, dsupers, dslots);
433 }
434
435
436 \f
437
438 void
439 scm_i_init_deprecated ()
440 {
441 #include "libguile/deprecated.x"
442 }
443
444 #endif