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
;
99 scm_init_deprecated_goops (void)
101 scm_no_applicable_method
=
102 scm_variable_ref (scm_c_lookup ("no-applicable-method"));
105 #define BUFFSIZE 32 /* big enough for most uses */
107 (scm_slot_ref (x, scm_slot_ref (x, scm_from_latin1_symbol ("specializers"))))
109 (scm_slot_ref (x, scm_slot_ref (x, scm_from_latin1_symbol ("cpl"))))
112 scm_i_vector2list (SCM l
, long len
)
115 SCM z
= scm_c_make_vector (len
, SCM_UNDEFINED
);
117 for (j
= 0; j
< len
; j
++, l
= SCM_CDR (l
)) {
118 SCM_SIMPLE_VECTOR_SET (z
, j
, SCM_CAR (l
));
124 applicablep (SCM actual
, SCM formal
)
126 /* We already know that the cpl is well formed. */
127 return scm_is_true (scm_c_memq (formal
, CPL_OF (actual
)));
131 more_specificp (SCM m1
, SCM m2
, SCM
const *targs
)
137 * m1 and m2 can have != length (i.e. one can be one element longer than the
138 * other when we have a dotted parameter list). For instance, with the call
141 * (define-method M (a . l) ....)
142 * (define-method M (a) ....)
144 * we consider that the second method is more specific.
146 * BTW, targs is an array of types. We don't need it's size since
147 * we already know that m1 and m2 are applicable (no risk to go past
148 * the end of this array).
151 for (i
=0, s1
=SPEC_OF(m1
), s2
=SPEC_OF(m2
); ; i
++, s1
=SCM_CDR(s1
), s2
=SCM_CDR(s2
)) {
152 if (scm_is_null(s1
)) return 1;
153 if (scm_is_null(s2
)) return 0;
154 if (!scm_is_eq (SCM_CAR(s1
), SCM_CAR(s2
))) {
155 register SCM l
, cs1
= SCM_CAR(s1
), cs2
= SCM_CAR(s2
);
157 for (l
= CPL_OF (targs
[i
]); ; l
= SCM_CDR(l
)) {
158 if (scm_is_eq (cs1
, SCM_CAR (l
)))
160 if (scm_is_eq (cs2
, SCM_CAR (l
)))
163 return 0;/* should not occur! */
166 return 0; /* should not occur! */
170 sort_applicable_methods (SCM method_list
, long size
, SCM
const *targs
)
173 SCM
*v
, vector
= SCM_EOL
;
174 SCM buffer
[BUFFSIZE
];
175 SCM save
= method_list
;
176 scm_t_array_handle handle
;
178 /* For reasonably sized method_lists we can try to avoid all the
179 * consing and reorder the list in place...
180 * This idea is due to David McClain <Dave_McClain@msn.com>
182 if (size
<= BUFFSIZE
)
184 for (i
= 0; i
< size
; i
++)
186 buffer
[i
] = SCM_CAR (method_list
);
187 method_list
= SCM_CDR (method_list
);
193 /* Too many elements in method_list to keep everything locally */
194 vector
= scm_i_vector2list (save
, size
);
195 v
= scm_vector_writable_elements (vector
, &handle
, NULL
, NULL
);
198 /* Use a simple shell sort since it is generally faster than qsort on
199 * small vectors (which is probably mostly the case when we have to
200 * sort a list of applicable methods).
202 for (incr
= size
/ 2; incr
; incr
/= 2)
204 for (i
= incr
; i
< size
; i
++)
206 for (j
= i
- incr
; j
>= 0; j
-= incr
)
208 if (more_specificp (v
[j
], v
[j
+incr
], targs
))
212 SCM tmp
= v
[j
+ incr
];
220 if (size
<= BUFFSIZE
)
222 /* We did it in locally, so restore the original list (reordered) in-place */
223 for (i
= 0, method_list
= save
; i
< size
; i
++, v
++)
225 SCM_SETCAR (method_list
, *v
);
226 method_list
= SCM_CDR (method_list
);
231 /* If we are here, that's that we did it the hard way... */
232 scm_array_handle_release (&handle
);
233 return scm_vector_to_list (vector
);
237 scm_compute_applicable_methods (SCM gf
, SCM args
, long len
, int find_method_p
)
241 SCM l
, fl
, applicable
= SCM_EOL
;
243 SCM buffer
[BUFFSIZE
];
247 scm_t_array_handle handle
;
249 scm_c_issue_deprecation_warning
250 ("scm_compute_applicable_methods is deprecated. Use "
251 "`compute-applicable-methods' from Scheme instead.");
253 /* Build the list of arguments types */
256 tmp
= scm_c_make_vector (len
, SCM_UNDEFINED
);
257 types
= p
= scm_vector_writable_elements (tmp
, &handle
, NULL
, NULL
);
260 note that we don't have to work to reset the generation
261 count. TMP is a new vector anyway, and it is found
268 for ( ; !scm_is_null (args
); args
= SCM_CDR (args
))
269 *p
++ = scm_class_of (SCM_CAR (args
));
271 /* Build a list of all applicable methods */
272 for (l
= scm_generic_function_methods (gf
); !scm_is_null (l
); l
= SCM_CDR (l
))
274 fl
= SPEC_OF (SCM_CAR (l
));
275 for (i
= 0; ; i
++, fl
= SCM_CDR (fl
))
277 if (SCM_INSTANCEP (fl
)
278 /* We have a dotted argument list */
279 || (i
>= len
&& scm_is_null (fl
)))
280 { /* both list exhausted */
281 applicable
= scm_cons (SCM_CAR (l
), applicable
);
287 || !applicablep (types
[i
], SCM_CAR (fl
)))
293 scm_array_handle_release (&handle
);
299 scm_call_2 (scm_no_applicable_method
, gf
, save
);
300 /* if we are here, it's because no-applicable-method hasn't signaled an error */
306 : sort_applicable_methods (applicable
, count
, types
));
309 SCM_SYMBOL (sym_compute_applicable_methods
, "compute-applicable-methods");
312 scm_find_method (SCM l
)
313 #define FUNC_NAME "find-method"
316 long len
= scm_ilength (l
);
319 SCM_WRONG_NUM_ARGS ();
321 scm_c_issue_deprecation_warning
322 ("scm_find_method is deprecated. Use `compute-applicable-methods' "
323 "from Scheme instead.");
325 gf
= SCM_CAR(l
); l
= SCM_CDR(l
);
326 SCM_VALIDATE_GENERIC (1, gf
);
327 if (scm_is_null (scm_slot_ref (gf
, scm_from_latin1_symbol ("methods"))))
328 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf
));
330 return scm_compute_applicable_methods (gf
, l
, len
- 1, 1);
335 scm_basic_make_class (SCM meta
, SCM name
, SCM dsupers
, SCM dslots
)
337 scm_c_issue_deprecation_warning
338 ("scm_basic_make_class is deprecated. Use `define-class' in Scheme,"
339 "or use `(make META #:name NAME #:dsupers DSUPERS #:slots DSLOTS)' "
342 return scm_make_standard_class (meta
, name
, dsupers
, dslots
);
349 scm_i_init_deprecated ()
351 #include "libguile/deprecated.x"