Commit | Line | Data |
---|---|---|
19e2247d MV |
1 | /* This file contains definitions for deprecated features. When you |
2 | deprecate something, move it here when that is feasible. | |
3 | */ | |
4 | ||
28b818d3 | 5 | /* Copyright (C) 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc. |
19e2247d | 6 | * |
73be1d9e | 7 | * This library is free software; you can redistribute it and/or |
53befeb7 NJ |
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. | |
19e2247d | 11 | * |
53befeb7 NJ |
12 | * This library is distributed in the hope that it will be useful, but |
13 | * WITHOUT ANY WARRANTY; without even the implied warranty of | |
73be1d9e MV |
14 | * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU |
15 | * Lesser General Public License for more details. | |
19e2247d | 16 | * |
73be1d9e MV |
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 | |
53befeb7 NJ |
19 | * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA |
20 | * 02110-1301 USA | |
73be1d9e | 21 | */ |
19e2247d | 22 | |
dbb605f5 LC |
23 | #ifdef HAVE_CONFIG_H |
24 | # include <config.h> | |
25 | #endif | |
26 | ||
0eb934f1 LC |
27 | #define SCM_BUILDING_DEPRECATED_CODE |
28 | ||
19e2247d | 29 | #include "libguile/_scm.h" |
55d30fac | 30 | #include "libguile/deprecation.h" |
3452e666 | 31 | |
19e2247d MV |
32 | #if (SCM_ENABLE_DEPRECATED == 1) |
33 | ||
f3c6a02c AW |
34 | \f |
35 | ||
b2feee6b AW |
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 | ||
65619ebe AW |
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 | ||
c2247b78 AW |
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 | ||
623559f3 AW |
96 | SCM scm_no_applicable_method = SCM_BOOL_F; |
97 | ||
57898597 AW |
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 | ||
623559f3 AW |
128 | void |
129 | scm_init_deprecated_goops (void) | |
130 | { | |
131 | scm_no_applicable_method = | |
132 | scm_variable_ref (scm_c_lookup ("no-applicable-method")); | |
57898597 AW |
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; | |
623559f3 AW |
193 | } |
194 | ||
e4aa440a | 195 | #define BUFFSIZE 32 /* big enough for most uses */ |
6c7dd9eb AW |
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")))) | |
e4aa440a AW |
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. */ | |
6c7dd9eb | 217 | return scm_is_true (scm_c_memq (formal, CPL_OF (actual))); |
e4aa440a AW |
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 | ||
6c7dd9eb | 247 | for (l = CPL_OF (targs[i]); ; l = SCM_CDR(l)) { |
e4aa440a AW |
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); | |
6c7dd9eb | 417 | if (scm_is_null (scm_slot_ref (gf, scm_from_latin1_symbol ("methods")))) |
e4aa440a AW |
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 | ||
28b818d3 AW |
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 | ||
e4aa440a AW |
435 | |
436 | \f | |
437 | ||
19e2247d MV |
438 | void |
439 | scm_i_init_deprecated () | |
440 | { | |
441 | #include "libguile/deprecated.x" | |
442 | } | |
443 | ||
444 | #endif |