1 /* This file contains definitions for deprecated features. When you
2 deprecate something, move it here when that is feasible.
5 /* Copyright (C) 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
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.
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.
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
27 #define SCM_BUILDING_DEPRECATED_CODE
29 #include "libguile/_scm.h"
30 #include "libguile/deprecation.h"
32 #if (SCM_ENABLE_DEPRECATED == 1)
37 scm_internal_dynamic_wind (scm_t_guard before
,
45 scm_c_issue_deprecation_warning
46 ("`scm_internal_dynamic_wind' is deprecated. "
47 "Use the `scm_dynwind_begin' / `scm_dynwind_end' API instead.");
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
);
60 scm_immutable_cell (scm_t_bits car
, scm_t_bits cdr
)
62 scm_c_issue_deprecation_warning
63 ("scm_immutable_cell is deprecated. Use scm_cell instead.");
65 return scm_cell (car
, cdr
);
69 scm_immutable_double_cell (scm_t_bits car
, scm_t_bits cbr
,
70 scm_t_bits ccr
, scm_t_bits cdr
)
72 scm_c_issue_deprecation_warning
73 ("scm_immutable_double_cell is deprecated. Use scm_double_cell instead.");
75 return scm_double_cell (car
, cbr
, ccr
, cdr
);
81 SCM_GLOBAL_SYMBOL (scm_memory_alloc_key
, "memory-allocation-error");
83 scm_memory_error (const char *subr
)
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.");
89 fprintf (stderr
, "FATAL: memory error in %s\n", subr
);
96 SCM scm_no_applicable_method
= SCM_BOOL_F
;
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
;
124 SCM scm_class_int
, scm_class_float
, scm_class_double
;
126 SCM
*scm_port_class
, *scm_smob_class
;
129 scm_init_deprecated_goops (void)
131 scm_no_applicable_method
=
132 scm_variable_ref (scm_c_lookup ("no-applicable-method"));
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>"));
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>"));
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>"));
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>"));
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>"));
191 scm_port_class
= scm_i_port_class
;
192 scm_smob_class
= scm_i_smob_class
;
195 #define BUFFSIZE 32 /* big enough for most uses */
197 (scm_slot_ref (x, scm_slot_ref (x, scm_from_latin1_symbol ("specializers"))))
199 (scm_slot_ref (x, scm_slot_ref (x, scm_from_latin1_symbol ("cpl"))))
202 scm_i_vector2list (SCM l
, long len
)
205 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
207 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
208 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
214 applicablep (SCM actual
, SCM formal
)
216 /* We already know that the cpl is well formed. */
217 return scm_is_true (scm_c_memq (formal
, CPL_OF (actual
)));
221 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
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
231 * (define-method M (a . l) ....)
232 * (define-method M (a) ....)
234 * we consider that the second method is more specific.
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).
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
);
247 for (l
= CPL_OF (targs
[i
]); ; l
= SCM_CDR(l
)) {
248 if (scm_is_eq (cs1
, SCM_CAR (l
)))
250 if (scm_is_eq (cs2
, SCM_CAR (l
)))
253 return 0;/* should not occur! */
256 return 0; /* should not occur! */
260 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
263 SCM
*v
, vector
= SCM_EOL
;
264 SCM buffer
[BUFFSIZE
];
265 SCM save
= method_list
;
266 scm_t_array_handle handle
;
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>
272 if (size
<= BUFFSIZE
)
274 for (i
= 0; i
< size
; i
++)
276 buffer
[i
] = SCM_CAR (method_list
);
277 method_list
= SCM_CDR (method_list
);
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
);
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).
292 for (incr
= size
/ 2; incr
; incr
/= 2)
294 for (i
= incr
; i
< size
; i
++)
296 for (j
= i
- incr
; j
>= 0; j
-= incr
)
298 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
302 SCM tmp
= v
[j
+ incr
];
310 if (size
<= BUFFSIZE
)
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
++)
315 SCM_SETCAR (method_list
, *v
);
316 method_list
= SCM_CDR (method_list
);
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
);
327 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
331 SCM l
, fl
, applicable
= SCM_EOL
;
333 SCM buffer
[BUFFSIZE
];
337 scm_t_array_handle handle
;
339 scm_c_issue_deprecation_warning
340 ("scm_compute_applicable_methods is deprecated. Use "
341 "`compute-applicable-methods' from Scheme instead.");
343 /* Build the list of arguments types */
346 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
347 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
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
358 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
359 *p
++ = scm_class_of (SCM_CAR (args
));
361 /* Build a list of all applicable methods */
362 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
364 fl
= SPEC_OF (SCM_CAR (l
));
365 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
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
);
377 || !applicablep (types
[i
], SCM_CAR (fl
)))
383 scm_array_handle_release (&handle
);
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 */
396 : sort_applicable_methods (applicable
, count
, types
));
399 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
402 scm_find_method (SCM l
)
403 #define FUNC_NAME "find-method"
406 long len
= scm_ilength (l
);
409 SCM_WRONG_NUM_ARGS ();
411 scm_c_issue_deprecation_warning
412 ("scm_find_method is deprecated. Use `compute-applicable-methods' "
413 "from Scheme instead.");
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
));
420 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
425 scm_basic_make_class (SCM meta
, SCM name
, SCM dsupers
, SCM dslots
)
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)' "
432 return scm_make_standard_class (meta
, name
, dsupers
, dslots
);
439 scm_i_init_deprecated ()
441 #include "libguile/deprecated.x"