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 static SCM var_slot_ref_using_class
= SCM_BOOL_F
;
97 static SCM var_slot_set_using_class_x
= SCM_BOOL_F
;
98 static SCM var_slot_bound_using_class_p
= SCM_BOOL_F
;
99 static SCM var_slot_exists_using_class_p
= SCM_BOOL_F
;
101 SCM scm_no_applicable_method
= SCM_BOOL_F
;
103 SCM var_get_keyword
= SCM_BOOL_F
;
105 SCM scm_class_boolean
, scm_class_char
, scm_class_pair
;
106 SCM scm_class_procedure
, scm_class_string
, scm_class_symbol
;
107 SCM scm_class_primitive_generic
;
108 SCM scm_class_vector
, scm_class_null
;
109 SCM scm_class_integer
, scm_class_real
, scm_class_complex
, scm_class_fraction
;
110 SCM scm_class_unknown
;
111 SCM scm_class_top
, scm_class_object
, scm_class_class
;
112 SCM scm_class_applicable
;
113 SCM scm_class_applicable_struct
, scm_class_applicable_struct_with_setter
;
114 SCM scm_class_generic
, scm_class_generic_with_setter
;
115 SCM scm_class_accessor
;
116 SCM scm_class_extended_generic
, scm_class_extended_generic_with_setter
;
117 SCM scm_class_extended_accessor
;
118 SCM scm_class_method
;
119 SCM scm_class_accessor_method
;
120 SCM scm_class_procedure_class
;
121 SCM scm_class_applicable_struct_class
;
122 SCM scm_class_number
, scm_class_list
;
123 SCM scm_class_keyword
;
124 SCM scm_class_port
, scm_class_input_output_port
;
125 SCM scm_class_input_port
, scm_class_output_port
;
126 SCM scm_class_foreign_slot
;
127 SCM scm_class_self
, scm_class_protected
;
128 SCM scm_class_hidden
, scm_class_opaque
, scm_class_read_only
;
129 SCM scm_class_protected_hidden
, scm_class_protected_opaque
, scm_class_protected_read_only
;
131 SCM scm_class_int
, scm_class_float
, scm_class_double
;
133 SCM
*scm_port_class
, *scm_smob_class
;
136 scm_init_deprecated_goops (void)
138 var_slot_ref_using_class
= scm_c_lookup ("slot-ref-using-class");
139 var_slot_set_using_class_x
= scm_c_lookup ("slot-set-using-class!");
140 var_slot_bound_using_class_p
= scm_c_lookup ("slot-bound-using-class?");
141 var_slot_exists_using_class_p
= scm_c_lookup ("slot-exists-using-class?");
143 scm_no_applicable_method
=
144 scm_variable_ref (scm_c_lookup ("no-applicable-method"));
146 var_get_keyword
= scm_c_lookup ("get-keyword");
148 scm_class_class
= scm_variable_ref (scm_c_lookup ("<class>"));
149 scm_class_top
= scm_variable_ref (scm_c_lookup ("<top>"));
150 scm_class_object
= scm_variable_ref (scm_c_lookup ("<object>"));
152 scm_class_foreign_slot
= scm_variable_ref (scm_c_lookup ("<foreign-slot>"));
153 scm_class_protected
= scm_variable_ref (scm_c_lookup ("<protected-slot>"));
154 scm_class_hidden
= scm_variable_ref (scm_c_lookup ("<hidden-slot>"));
155 scm_class_opaque
= scm_variable_ref (scm_c_lookup ("<opaque-slot>"));
156 scm_class_read_only
= scm_variable_ref (scm_c_lookup ("<read-only-slot>"));
157 scm_class_self
= scm_variable_ref (scm_c_lookup ("<self-slot>"));
158 scm_class_protected_opaque
= scm_variable_ref (scm_c_lookup ("<protected-opaque-slot>"));
159 scm_class_protected_hidden
= scm_variable_ref (scm_c_lookup ("<protected-hidden-slot>"));
160 scm_class_protected_read_only
= scm_variable_ref (scm_c_lookup ("<protected-read-only-slot>"));
161 scm_class_scm
= scm_variable_ref (scm_c_lookup ("<scm-slot>"));
162 scm_class_int
= scm_variable_ref (scm_c_lookup ("<int-slot>"));
163 scm_class_float
= scm_variable_ref (scm_c_lookup ("<float-slot>"));
164 scm_class_double
= scm_variable_ref (scm_c_lookup ("<double-slot>"));
166 /* scm_class_generic functions classes */
167 scm_class_procedure_class
= scm_variable_ref (scm_c_lookup ("<procedure-class>"));
168 scm_class_applicable_struct_class
= scm_variable_ref (scm_c_lookup ("<applicable-struct-class>"));
170 scm_class_method
= scm_variable_ref (scm_c_lookup ("<method>"));
171 scm_class_accessor_method
= scm_variable_ref (scm_c_lookup ("<accessor-method>"));
172 scm_class_applicable
= scm_variable_ref (scm_c_lookup ("<applicable>"));
173 scm_class_applicable_struct
= scm_variable_ref (scm_c_lookup ("<applicable-struct>"));
174 scm_class_applicable_struct_with_setter
= scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter>"));
175 scm_class_generic
= scm_variable_ref (scm_c_lookup ("<generic>"));
176 scm_class_extended_generic
= scm_variable_ref (scm_c_lookup ("<extended-generic>"));
177 scm_class_generic_with_setter
= scm_variable_ref (scm_c_lookup ("<generic-with-setter>"));
178 scm_class_accessor
= scm_variable_ref (scm_c_lookup ("<accessor>"));
179 scm_class_extended_generic_with_setter
= scm_variable_ref (scm_c_lookup ("<extended-generic-with-setter>"));
180 scm_class_extended_accessor
= scm_variable_ref (scm_c_lookup ("<extended-accessor>"));
182 /* Primitive types classes */
183 scm_class_boolean
= scm_variable_ref (scm_c_lookup ("<boolean>"));
184 scm_class_char
= scm_variable_ref (scm_c_lookup ("<char>"));
185 scm_class_list
= scm_variable_ref (scm_c_lookup ("<list>"));
186 scm_class_pair
= scm_variable_ref (scm_c_lookup ("<pair>"));
187 scm_class_null
= scm_variable_ref (scm_c_lookup ("<null>"));
188 scm_class_string
= scm_variable_ref (scm_c_lookup ("<string>"));
189 scm_class_symbol
= scm_variable_ref (scm_c_lookup ("<symbol>"));
190 scm_class_vector
= scm_variable_ref (scm_c_lookup ("<vector>"));
191 scm_class_number
= scm_variable_ref (scm_c_lookup ("<number>"));
192 scm_class_complex
= scm_variable_ref (scm_c_lookup ("<complex>"));
193 scm_class_real
= scm_variable_ref (scm_c_lookup ("<real>"));
194 scm_class_integer
= scm_variable_ref (scm_c_lookup ("<integer>"));
195 scm_class_fraction
= scm_variable_ref (scm_c_lookup ("<fraction>"));
196 scm_class_keyword
= scm_variable_ref (scm_c_lookup ("<keyword>"));
197 scm_class_unknown
= scm_variable_ref (scm_c_lookup ("<unknown>"));
198 scm_class_procedure
= scm_variable_ref (scm_c_lookup ("<procedure>"));
199 scm_class_primitive_generic
= scm_variable_ref (scm_c_lookup ("<primitive-generic>"));
200 scm_class_port
= scm_variable_ref (scm_c_lookup ("<port>"));
201 scm_class_input_port
= scm_variable_ref (scm_c_lookup ("<input-port>"));
202 scm_class_output_port
= scm_variable_ref (scm_c_lookup ("<output-port>"));
203 scm_class_input_output_port
= scm_variable_ref (scm_c_lookup ("<input-output-port>"));
205 scm_port_class
= scm_i_port_class
;
206 scm_smob_class
= scm_i_smob_class
;
210 scm_get_keyword (SCM kw
, SCM initargs
, SCM default_value
)
212 scm_c_issue_deprecation_warning
213 ("scm_get_keyword is deprecated. Use `kw-arg-ref' from Scheme instead.");
215 return scm_call_3 (scm_variable_ref (var_get_keyword
),
216 kw
, initargs
, default_value
);
219 #define BUFFSIZE 32 /* big enough for most uses */
221 (scm_slot_ref (x, scm_slot_ref (x, scm_from_latin1_symbol ("specializers"))))
223 (scm_slot_ref (x, scm_slot_ref (x, scm_from_latin1_symbol ("cpl"))))
226 scm_i_vector2list (SCM l
, long len
)
229 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
231 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
232 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
238 applicablep (SCM actual
, SCM formal
)
240 /* We already know that the cpl is well formed. */
241 return scm_is_true (scm_c_memq (formal
, CPL_OF (actual
)));
245 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
251 * m1 and m2 can have != length (i.e. one can be one element longer than the
252 * other when we have a dotted parameter list). For instance, with the call
255 * (define-method M (a . l) ....)
256 * (define-method M (a) ....)
258 * we consider that the second method is more specific.
260 * BTW, targs is an array of types. We don't need it's size since
261 * we already know that m1 and m2 are applicable (no risk to go past
262 * the end of this array).
265 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
266 if (scm_is_null(s1
)) return 1;
267 if (scm_is_null(s2
)) return 0;
268 if (!scm_is_eq (SCM_CAR(s1
), SCM_CAR(s2
))) {
269 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
271 for (l
= CPL_OF (targs
[i
]); ; l
= SCM_CDR(l
)) {
272 if (scm_is_eq (cs1
, SCM_CAR (l
)))
274 if (scm_is_eq (cs2
, SCM_CAR (l
)))
277 return 0;/* should not occur! */
280 return 0; /* should not occur! */
284 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
287 SCM
*v
, vector
= SCM_EOL
;
288 SCM buffer
[BUFFSIZE
];
289 SCM save
= method_list
;
290 scm_t_array_handle handle
;
292 /* For reasonably sized method_lists we can try to avoid all the
293 * consing and reorder the list in place...
294 * This idea is due to David McClain <Dave_McClain@msn.com>
296 if (size
<= BUFFSIZE
)
298 for (i
= 0; i
< size
; i
++)
300 buffer
[i
] = SCM_CAR (method_list
);
301 method_list
= SCM_CDR (method_list
);
307 /* Too many elements in method_list to keep everything locally */
308 vector
= scm_i_vector2list (save
, size
);
309 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
312 /* Use a simple shell sort since it is generally faster than qsort on
313 * small vectors (which is probably mostly the case when we have to
314 * sort a list of applicable methods).
316 for (incr
= size
/ 2; incr
; incr
/= 2)
318 for (i
= incr
; i
< size
; i
++)
320 for (j
= i
- incr
; j
>= 0; j
-= incr
)
322 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
326 SCM tmp
= v
[j
+ incr
];
334 if (size
<= BUFFSIZE
)
336 /* We did it in locally, so restore the original list (reordered) in-place */
337 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
339 SCM_SETCAR (method_list
, *v
);
340 method_list
= SCM_CDR (method_list
);
345 /* If we are here, that's that we did it the hard way... */
346 scm_array_handle_release (&handle
);
347 return scm_vector_to_list (vector
);
351 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
355 SCM l
, fl
, applicable
= SCM_EOL
;
357 SCM buffer
[BUFFSIZE
];
361 scm_t_array_handle handle
;
363 scm_c_issue_deprecation_warning
364 ("scm_compute_applicable_methods is deprecated. Use "
365 "`compute-applicable-methods' from Scheme instead.");
367 /* Build the list of arguments types */
370 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
371 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
374 note that we don't have to work to reset the generation
375 count. TMP is a new vector anyway, and it is found
382 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
383 *p
++ = scm_class_of (SCM_CAR (args
));
385 /* Build a list of all applicable methods */
386 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
388 fl
= SPEC_OF (SCM_CAR (l
));
389 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
391 if (SCM_INSTANCEP (fl
)
392 /* We have a dotted argument list */
393 || (i
>= len
&& scm_is_null (fl
)))
394 { /* both list exhausted */
395 applicable
= scm_cons (SCM_CAR (l
), applicable
);
401 || !applicablep (types
[i
], SCM_CAR (fl
)))
407 scm_array_handle_release (&handle
);
413 scm_call_2 (scm_no_applicable_method
, gf
, save
);
414 /* if we are here, it's because no-applicable-method hasn't signaled an error */
420 : sort_applicable_methods (applicable
, count
, types
));
423 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
426 scm_find_method (SCM l
)
427 #define FUNC_NAME "find-method"
430 long len
= scm_ilength (l
);
433 SCM_WRONG_NUM_ARGS ();
435 scm_c_issue_deprecation_warning
436 ("scm_find_method is deprecated. Use `compute-applicable-methods' "
437 "from Scheme instead.");
439 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
440 SCM_VALIDATE_GENERIC (1, gf
);
441 if (scm_is_null (scm_slot_ref (gf
, scm_from_latin1_symbol ("methods"))))
442 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
444 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
449 scm_basic_make_class (SCM meta
, SCM name
, SCM dsupers
, SCM dslots
)
451 scm_c_issue_deprecation_warning
452 ("scm_basic_make_class is deprecated. Use `define-class' in Scheme,"
453 "or use `(make META #:name NAME #:dsupers DSUPERS #:slots DSLOTS)' "
456 return scm_make_standard_class (meta
, name
, dsupers
, dslots
);
459 /* Scheme will issue the deprecation warning for these. */
461 scm_slot_ref_using_class (SCM
class, SCM obj
, SCM slot_name
)
463 return scm_call_3 (scm_variable_ref (var_slot_ref_using_class
),
464 class, obj
, slot_name
);
468 scm_slot_set_using_class_x (SCM
class, SCM obj
, SCM slot_name
, SCM value
)
470 return scm_call_4 (scm_variable_ref (var_slot_set_using_class_x
),
471 class, obj
, slot_name
, value
);
475 scm_slot_bound_using_class_p (SCM
class, SCM obj
, SCM slot_name
)
477 return scm_call_3 (scm_variable_ref (var_slot_bound_using_class_p
),
478 class, obj
, slot_name
);
482 scm_slot_exists_using_class_p (SCM
class, SCM obj
, SCM slot_name
)
484 return scm_call_3 (scm_variable_ref (var_slot_exists_using_class_p
),
485 class, obj
, slot_name
);
492 scm_i_init_deprecated ()
494 #include "libguile/deprecated.x"