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, 2017 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 <alloca.h>
30 #include <sys/types.h>
31 #include <unistd.h>
32
33 #include "libguile/_scm.h"
34 #include "libguile/deprecation.h"
35
36 #if (SCM_ENABLE_DEPRECATED == 1)
37
38
39
40 SCM
scm_internal_dynamic_wind(scm_t_guard before,scm_t_inner inner,scm_t_guard after,void * inner_data,void * guard_data)41 scm_internal_dynamic_wind (scm_t_guard before,
42 scm_t_inner inner,
43 scm_t_guard after,
44 void *inner_data,
45 void *guard_data)
46 {
47 SCM ans;
48
49 scm_c_issue_deprecation_warning
50 ("`scm_internal_dynamic_wind' is deprecated. "
51 "Use the `scm_dynwind_begin' / `scm_dynwind_end' API instead.");
52
53 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
54 scm_dynwind_rewind_handler (before, guard_data, SCM_F_WIND_EXPLICITLY);
55 scm_dynwind_unwind_handler (after, guard_data, SCM_F_WIND_EXPLICITLY);
56 ans = inner (inner_data);
57 scm_dynwind_end ();
58 return ans;
59 }
60
61
62
63 SCM
scm_immutable_cell(scm_t_bits car,scm_t_bits cdr)64 scm_immutable_cell (scm_t_bits car, scm_t_bits cdr)
65 {
66 scm_c_issue_deprecation_warning
67 ("scm_immutable_cell is deprecated. Use scm_cell instead.");
68
69 return scm_cell (car, cdr);
70 }
71
72 SCM
scm_immutable_double_cell(scm_t_bits car,scm_t_bits cbr,scm_t_bits ccr,scm_t_bits cdr)73 scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
74 scm_t_bits ccr, scm_t_bits cdr)
75 {
76 scm_c_issue_deprecation_warning
77 ("scm_immutable_double_cell is deprecated. Use scm_double_cell instead.");
78
79 return scm_double_cell (car, cbr, ccr, cdr);
80 }
81
82
83
84
85 SCM_GLOBAL_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
86 void
scm_memory_error(const char * subr)87 scm_memory_error (const char *subr)
88 {
89 scm_c_issue_deprecation_warning
90 ("scm_memory_error is deprecated. Use scm_report_out_of_memory to raise "
91 "an exception, or abort() to cause the program to exit.");
92
93 fprintf (stderr, "FATAL: memory error in %s\n", subr);
94 abort ();
95 }
96
97
98
99
100 static SCM var_slot_ref_using_class = SCM_BOOL_F;
101 static SCM var_slot_set_using_class_x = SCM_BOOL_F;
102 static SCM var_slot_bound_using_class_p = SCM_BOOL_F;
103 static SCM var_slot_exists_using_class_p = SCM_BOOL_F;
104
105 SCM scm_no_applicable_method = SCM_BOOL_F;
106
107 SCM var_get_keyword = SCM_BOOL_F;
108
109 SCM scm_class_boolean, scm_class_char, scm_class_pair;
110 SCM scm_class_procedure, scm_class_string, scm_class_symbol;
111 SCM scm_class_primitive_generic;
112 SCM scm_class_vector, scm_class_null;
113 SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction;
114 SCM scm_class_unknown;
115 SCM scm_class_top, scm_class_object, scm_class_class;
116 SCM scm_class_applicable;
117 SCM scm_class_applicable_struct, scm_class_applicable_struct_with_setter;
118 SCM scm_class_generic, scm_class_generic_with_setter;
119 SCM scm_class_accessor;
120 SCM scm_class_extended_generic, scm_class_extended_generic_with_setter;
121 SCM scm_class_extended_accessor;
122 SCM scm_class_method;
123 SCM scm_class_accessor_method;
124 SCM scm_class_procedure_class;
125 SCM scm_class_applicable_struct_class;
126 SCM scm_class_number, scm_class_list;
127 SCM scm_class_keyword;
128 SCM scm_class_port, scm_class_input_output_port;
129 SCM scm_class_input_port, scm_class_output_port;
130 SCM scm_class_foreign_slot;
131 SCM scm_class_self, scm_class_protected;
132 SCM scm_class_hidden, scm_class_opaque, scm_class_read_only;
133 SCM scm_class_protected_hidden, scm_class_protected_opaque, scm_class_protected_read_only;
134 SCM scm_class_scm;
135 SCM scm_class_int, scm_class_float, scm_class_double;
136
137 SCM *scm_port_class, *scm_smob_class;
138
139 void
scm_init_deprecated_goops(void)140 scm_init_deprecated_goops (void)
141 {
142 var_slot_ref_using_class = scm_c_lookup ("slot-ref-using-class");
143 var_slot_set_using_class_x = scm_c_lookup ("slot-set-using-class!");
144 var_slot_bound_using_class_p = scm_c_lookup ("slot-bound-using-class?");
145 var_slot_exists_using_class_p = scm_c_lookup ("slot-exists-using-class?");
146
147 scm_no_applicable_method =
148 scm_variable_ref (scm_c_lookup ("no-applicable-method"));
149
150 var_get_keyword = scm_c_lookup ("get-keyword");
151
152 scm_class_class = scm_variable_ref (scm_c_lookup ("<class>"));
153 scm_class_top = scm_variable_ref (scm_c_lookup ("<top>"));
154 scm_class_object = scm_variable_ref (scm_c_lookup ("<object>"));
155
156 scm_class_foreign_slot = scm_variable_ref (scm_c_lookup ("<foreign-slot>"));
157 scm_class_protected = scm_variable_ref (scm_c_lookup ("<protected-slot>"));
158 scm_class_hidden = scm_variable_ref (scm_c_lookup ("<hidden-slot>"));
159 scm_class_opaque = scm_variable_ref (scm_c_lookup ("<opaque-slot>"));
160 scm_class_read_only = scm_variable_ref (scm_c_lookup ("<read-only-slot>"));
161 scm_class_self = scm_variable_ref (scm_c_lookup ("<self-slot>"));
162 scm_class_protected_opaque = scm_variable_ref (scm_c_lookup ("<protected-opaque-slot>"));
163 scm_class_protected_hidden = scm_variable_ref (scm_c_lookup ("<protected-hidden-slot>"));
164 scm_class_protected_read_only = scm_variable_ref (scm_c_lookup ("<protected-read-only-slot>"));
165 scm_class_scm = scm_variable_ref (scm_c_lookup ("<scm-slot>"));
166 scm_class_int = scm_variable_ref (scm_c_lookup ("<int-slot>"));
167 scm_class_float = scm_variable_ref (scm_c_lookup ("<float-slot>"));
168 scm_class_double = scm_variable_ref (scm_c_lookup ("<double-slot>"));
169
170 /* scm_class_generic functions classes */
171 scm_class_procedure_class = scm_variable_ref (scm_c_lookup ("<procedure-class>"));
172 scm_class_applicable_struct_class = scm_variable_ref (scm_c_lookup ("<applicable-struct-class>"));
173
174 scm_class_method = scm_variable_ref (scm_c_lookup ("<method>"));
175 scm_class_accessor_method = scm_variable_ref (scm_c_lookup ("<accessor-method>"));
176 scm_class_applicable = scm_variable_ref (scm_c_lookup ("<applicable>"));
177 scm_class_applicable_struct = scm_variable_ref (scm_c_lookup ("<applicable-struct>"));
178 scm_class_applicable_struct_with_setter = scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter>"));
179 scm_class_generic = scm_variable_ref (scm_c_lookup ("<generic>"));
180 scm_class_extended_generic = scm_variable_ref (scm_c_lookup ("<extended-generic>"));
181 scm_class_generic_with_setter = scm_variable_ref (scm_c_lookup ("<generic-with-setter>"));
182 scm_class_accessor = scm_variable_ref (scm_c_lookup ("<accessor>"));
183 scm_class_extended_generic_with_setter = scm_variable_ref (scm_c_lookup ("<extended-generic-with-setter>"));
184 scm_class_extended_accessor = scm_variable_ref (scm_c_lookup ("<extended-accessor>"));
185
186 /* Primitive types classes */
187 scm_class_boolean = scm_variable_ref (scm_c_lookup ("<boolean>"));
188 scm_class_char = scm_variable_ref (scm_c_lookup ("<char>"));
189 scm_class_list = scm_variable_ref (scm_c_lookup ("<list>"));
190 scm_class_pair = scm_variable_ref (scm_c_lookup ("<pair>"));
191 scm_class_null = scm_variable_ref (scm_c_lookup ("<null>"));
192 scm_class_string = scm_variable_ref (scm_c_lookup ("<string>"));
193 scm_class_symbol = scm_variable_ref (scm_c_lookup ("<symbol>"));
194 scm_class_vector = scm_variable_ref (scm_c_lookup ("<vector>"));
195 scm_class_number = scm_variable_ref (scm_c_lookup ("<number>"));
196 scm_class_complex = scm_variable_ref (scm_c_lookup ("<complex>"));
197 scm_class_real = scm_variable_ref (scm_c_lookup ("<real>"));
198 scm_class_integer = scm_variable_ref (scm_c_lookup ("<integer>"));
199 scm_class_fraction = scm_variable_ref (scm_c_lookup ("<fraction>"));
200 scm_class_keyword = scm_variable_ref (scm_c_lookup ("<keyword>"));
201 scm_class_unknown = scm_variable_ref (scm_c_lookup ("<unknown>"));
202 scm_class_procedure = scm_variable_ref (scm_c_lookup ("<procedure>"));
203 scm_class_primitive_generic = scm_variable_ref (scm_c_lookup ("<primitive-generic>"));
204 scm_class_port = scm_variable_ref (scm_c_lookup ("<port>"));
205 scm_class_input_port = scm_variable_ref (scm_c_lookup ("<input-port>"));
206 scm_class_output_port = scm_variable_ref (scm_c_lookup ("<output-port>"));
207 scm_class_input_output_port = scm_variable_ref (scm_c_lookup ("<input-output-port>"));
208
209 scm_smob_class = scm_i_smob_class;
210 }
211
212 SCM
scm_get_keyword(SCM kw,SCM initargs,SCM default_value)213 scm_get_keyword (SCM kw, SCM initargs, SCM default_value)
214 {
215 scm_c_issue_deprecation_warning
216 ("scm_get_keyword is deprecated. Use `kw-arg-ref' from Scheme instead.");
217
218 return scm_call_3 (scm_variable_ref (var_get_keyword),
219 kw, initargs, default_value);
220 }
221
222 #define BUFFSIZE 32 /* big enough for most uses */
223 #define SPEC_OF(x) \
224 (scm_slot_ref (x, scm_slot_ref (x, scm_from_latin1_symbol ("specializers"))))
225 #define CPL_OF(x) \
226 (scm_slot_ref (x, scm_slot_ref (x, scm_from_latin1_symbol ("cpl"))))
227
228 static SCM
scm_i_vector2list(SCM l,long len)229 scm_i_vector2list (SCM l, long len)
230 {
231 long j;
232 SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
233
234 for (j = 0; j < len; j++, l = SCM_CDR (l)) {
235 SCM_SIMPLE_VECTOR_SET (z, j, SCM_CAR (l));
236 }
237 return z;
238 }
239
240 static int
applicablep(SCM actual,SCM formal)241 applicablep (SCM actual, SCM formal)
242 {
243 /* We already know that the cpl is well formed. */
244 return scm_is_true (scm_c_memq (formal, CPL_OF (actual)));
245 }
246
247 static int
more_specificp(SCM m1,SCM m2,SCM const * targs)248 more_specificp (SCM m1, SCM m2, SCM const *targs)
249 {
250 register SCM s1, s2;
251 register long i;
252 /*
253 * Note:
254 * m1 and m2 can have != length (i.e. one can be one element longer than the
255 * other when we have a dotted parameter list). For instance, with the call
256 * (M 1)
257 * with
258 * (define-method M (a . l) ....)
259 * (define-method M (a) ....)
260 *
261 * we consider that the second method is more specific.
262 *
263 * BTW, targs is an array of types. We don't need it's size since
264 * we already know that m1 and m2 are applicable (no risk to go past
265 * the end of this array).
266 *
267 */
268 for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) {
269 if (scm_is_null(s1)) return 1;
270 if (scm_is_null(s2)) return 0;
271 if (!scm_is_eq (SCM_CAR(s1), SCM_CAR(s2))) {
272 register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
273
274 for (l = CPL_OF (targs[i]); ; l = SCM_CDR(l)) {
275 if (scm_is_eq (cs1, SCM_CAR (l)))
276 return 1;
277 if (scm_is_eq (cs2, SCM_CAR (l)))
278 return 0;
279 }
280 return 0;/* should not occur! */
281 }
282 }
283 return 0; /* should not occur! */
284 }
285
286 static SCM
sort_applicable_methods(SCM method_list,long size,SCM const * targs)287 sort_applicable_methods (SCM method_list, long size, SCM const *targs)
288 {
289 long i, j, incr;
290 SCM *v, vector = SCM_EOL;
291 SCM buffer[BUFFSIZE];
292 SCM save = method_list;
293 scm_t_array_handle handle;
294
295 /* For reasonably sized method_lists we can try to avoid all the
296 * consing and reorder the list in place...
297 * This idea is due to David McClain <Dave_McClain@msn.com>
298 */
299 if (size <= BUFFSIZE)
300 {
301 for (i = 0; i < size; i++)
302 {
303 buffer[i] = SCM_CAR (method_list);
304 method_list = SCM_CDR (method_list);
305 }
306 v = buffer;
307 }
308 else
309 {
310 /* Too many elements in method_list to keep everything locally */
311 vector = scm_i_vector2list (save, size);
312 v = scm_vector_writable_elements (vector, &handle, NULL, NULL);
313 }
314
315 /* Use a simple shell sort since it is generally faster than qsort on
316 * small vectors (which is probably mostly the case when we have to
317 * sort a list of applicable methods).
318 */
319 for (incr = size / 2; incr; incr /= 2)
320 {
321 for (i = incr; i < size; i++)
322 {
323 for (j = i - incr; j >= 0; j -= incr)
324 {
325 if (more_specificp (v[j], v[j+incr], targs))
326 break;
327 else
328 {
329 SCM tmp = v[j + incr];
330 v[j + incr] = v[j];
331 v[j] = tmp;
332 }
333 }
334 }
335 }
336
337 if (size <= BUFFSIZE)
338 {
339 /* We did it in locally, so restore the original list (reordered) in-place */
340 for (i = 0, method_list = save; i < size; i++, v++)
341 {
342 SCM_SETCAR (method_list, *v);
343 method_list = SCM_CDR (method_list);
344 }
345 return save;
346 }
347
348 /* If we are here, that's that we did it the hard way... */
349 scm_array_handle_release (&handle);
350 return scm_vector_to_list (vector);
351 }
352
353 SCM
scm_compute_applicable_methods(SCM gf,SCM args,long len,int find_method_p)354 scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
355 {
356 register long i;
357 long count = 0;
358 SCM l, fl, applicable = SCM_EOL;
359 SCM save = args;
360 SCM buffer[BUFFSIZE];
361 SCM const *types;
362 SCM *p;
363 SCM tmp = SCM_EOL;
364 scm_t_array_handle handle;
365
366 scm_c_issue_deprecation_warning
367 ("scm_compute_applicable_methods is deprecated. Use "
368 "`compute-applicable-methods' from Scheme instead.");
369
370 /* Build the list of arguments types */
371 if (len >= BUFFSIZE)
372 {
373 tmp = scm_c_make_vector (len, SCM_UNDEFINED);
374 types = p = scm_vector_writable_elements (tmp, &handle, NULL, NULL);
375
376 /*
377 note that we don't have to work to reset the generation
378 count. TMP is a new vector anyway, and it is found
379 conservatively.
380 */
381 }
382 else
383 types = p = buffer;
384
385 for ( ; !scm_is_null (args); args = SCM_CDR (args))
386 *p++ = scm_class_of (SCM_CAR (args));
387
388 /* Build a list of all applicable methods */
389 for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
390 {
391 fl = SPEC_OF (SCM_CAR (l));
392 for (i = 0; ; i++, fl = SCM_CDR (fl))
393 {
394 if (SCM_INSTANCEP (fl)
395 /* We have a dotted argument list */
396 || (i >= len && scm_is_null (fl)))
397 { /* both list exhausted */
398 applicable = scm_cons (SCM_CAR (l), applicable);
399 count += 1;
400 break;
401 }
402 if (i >= len
403 || scm_is_null (fl)
404 || !applicablep (types[i], SCM_CAR (fl)))
405 break;
406 }
407 }
408
409 if (len >= BUFFSIZE)
410 scm_array_handle_release (&handle);
411
412 if (count == 0)
413 {
414 if (find_method_p)
415 return SCM_BOOL_F;
416 scm_call_2 (scm_no_applicable_method, gf, save);
417 /* if we are here, it's because no-applicable-method hasn't signaled an error */
418 return SCM_BOOL_F;
419 }
420
421 return (count == 1
422 ? applicable
423 : sort_applicable_methods (applicable, count, types));
424 }
425
426 SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
427
428 SCM
scm_find_method(SCM l)429 scm_find_method (SCM l)
430 #define FUNC_NAME "find-method"
431 {
432 SCM gf;
433 long len = scm_ilength (l);
434
435 if (len == 0)
436 SCM_WRONG_NUM_ARGS ();
437
438 scm_c_issue_deprecation_warning
439 ("scm_find_method is deprecated. Use `compute-applicable-methods' "
440 "from Scheme instead.");
441
442 gf = SCM_CAR(l); l = SCM_CDR(l);
443 SCM_VALIDATE_GENERIC (1, gf);
444 if (scm_is_null (scm_slot_ref (gf, scm_from_latin1_symbol ("methods"))))
445 SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf));
446
447 return scm_compute_applicable_methods (gf, l, len - 1, 1);
448 }
449 #undef FUNC_NAME
450
451 SCM
scm_basic_make_class(SCM meta,SCM name,SCM dsupers,SCM dslots)452 scm_basic_make_class (SCM meta, SCM name, SCM dsupers, SCM dslots)
453 {
454 scm_c_issue_deprecation_warning
455 ("scm_basic_make_class is deprecated. Use `define-class' in Scheme,"
456 "or use `(make META #:name NAME #:dsupers DSUPERS #:slots DSLOTS)' "
457 "in Scheme.");
458
459 return scm_make_standard_class (meta, name, dsupers, dslots);
460 }
461
462 /* Scheme will issue the deprecation warning for these. */
463 SCM
scm_slot_ref_using_class(SCM class,SCM obj,SCM slot_name)464 scm_slot_ref_using_class (SCM class, SCM obj, SCM slot_name)
465 {
466 return scm_call_3 (scm_variable_ref (var_slot_ref_using_class),
467 class, obj, slot_name);
468 }
469
470 SCM
scm_slot_set_using_class_x(SCM class,SCM obj,SCM slot_name,SCM value)471 scm_slot_set_using_class_x (SCM class, SCM obj, SCM slot_name, SCM value)
472 {
473 return scm_call_4 (scm_variable_ref (var_slot_set_using_class_x),
474 class, obj, slot_name, value);
475 }
476
477 SCM
scm_slot_bound_using_class_p(SCM class,SCM obj,SCM slot_name)478 scm_slot_bound_using_class_p (SCM class, SCM obj, SCM slot_name)
479 {
480 return scm_call_3 (scm_variable_ref (var_slot_bound_using_class_p),
481 class, obj, slot_name);
482 }
483
484 SCM
scm_slot_exists_using_class_p(SCM class,SCM obj,SCM slot_name)485 scm_slot_exists_using_class_p (SCM class, SCM obj, SCM slot_name)
486 {
487 return scm_call_3 (scm_variable_ref (var_slot_exists_using_class_p),
488 class, obj, slot_name);
489 }
490
491
492
493 #define FETCH_STORE(fet,mem,sto) \
494 do { \
495 scm_i_scm_pthread_mutex_lock (&scm_i_misc_mutex); \
496 (fet) = (mem); \
497 (mem) = (sto); \
498 scm_i_pthread_mutex_unlock (&scm_i_misc_mutex); \
499 } while (0)
500
501 static scm_t_bits scm_tc16_arbiter;
502
503
504 #define SCM_LOCK_VAL (scm_tc16_arbiter | (1L << 16))
505 #define SCM_UNLOCK_VAL scm_tc16_arbiter
506 #define SCM_ARB_LOCKED(arb) ((SCM_CELL_WORD_0 (arb)) & (1L << 16))
507
508
509 static int
arbiter_print(SCM exp,SCM port,scm_print_state * pstate)510 arbiter_print (SCM exp, SCM port, scm_print_state *pstate)
511 {
512 scm_puts ("#<arbiter ", port);
513 if (SCM_ARB_LOCKED (exp))
514 scm_puts ("locked ", port);
515 scm_iprin1 (SCM_PACK (SCM_SMOB_DATA (exp)), port, pstate);
516 scm_putc ('>', port);
517 return !0;
518 }
519
520 SCM_DEFINE (scm_make_arbiter, "make-arbiter", 1, 0, 0,
521 (SCM name),
522 "Return an arbiter object, initially unlocked. Currently\n"
523 "@var{name} is only used for diagnostic output.")
524 #define FUNC_NAME s_scm_make_arbiter
525 {
526 scm_c_issue_deprecation_warning
527 ("Arbiters are deprecated. "
528 "Use mutexes or atomic variables instead.");
529
530 SCM_RETURN_NEWSMOB (scm_tc16_arbiter, SCM_UNPACK (name));
531 }
532 #undef FUNC_NAME
533
534
535 /* The atomic FETCH_STORE here is so two threads can't both see the arbiter
536 unlocked and return #t. The arbiter itself wouldn't be corrupted by
537 this, but two threads both getting #t would be contrary to the intended
538 semantics. */
539
540 SCM_DEFINE (scm_try_arbiter, "try-arbiter", 1, 0, 0,
541 (SCM arb),
542 "If @var{arb} is unlocked, then lock it and return @code{#t}.\n"
543 "If @var{arb} is already locked, then do nothing and return\n"
544 "@code{#f}.")
545 #define FUNC_NAME s_scm_try_arbiter
546 {
547 scm_t_bits old;
548 scm_t_bits *loc;
549 SCM_VALIDATE_SMOB (1, arb, arbiter);
550 loc = (scm_t_bits*)SCM_SMOB_OBJECT_N_LOC (arb, 0);
551 FETCH_STORE (old, *loc, SCM_LOCK_VAL);
552 return scm_from_bool (old == SCM_UNLOCK_VAL);
553 }
554 #undef FUNC_NAME
555
556
557 /* The atomic FETCH_STORE here is so two threads can't both see the arbiter
558 locked and return #t. The arbiter itself wouldn't be corrupted by this,
559 but we don't want two threads both thinking they were the unlocker. The
560 intended usage is for the code which locked to be responsible for
561 unlocking, but we guarantee the return value even if multiple threads
562 compete. */
563
564 SCM_DEFINE (scm_release_arbiter, "release-arbiter", 1, 0, 0,
565 (SCM arb),
566 "If @var{arb} is locked, then unlock it and return @code{#t}.\n"
567 "If @var{arb} is already unlocked, then do nothing and return\n"
568 "@code{#f}.\n"
569 "\n"
570 "Typical usage is for the thread which locked an arbiter to\n"
571 "later release it, but that's not required, any thread can\n"
572 "release it.")
573 #define FUNC_NAME s_scm_release_arbiter
574 {
575 scm_t_bits old;
576 scm_t_bits *loc;
577 SCM_VALIDATE_SMOB (1, arb, arbiter);
578 loc = (scm_t_bits*)SCM_SMOB_OBJECT_N_LOC (arb, 0);
579 FETCH_STORE (old, *loc, SCM_UNLOCK_VAL);
580 return scm_from_bool (old == SCM_LOCK_VAL);
581 }
582 #undef FUNC_NAME
583
584
585
586
587 /* User asyncs. */
588
589 static scm_t_bits tc16_async;
590
591 /* cmm: this has SCM_ prefix because SCM_MAKE_VALIDATE expects it.
592 this is ugly. */
593 #define SCM_ASYNCP(X) SCM_TYP16_PREDICATE (tc16_async, X)
594 #define VALIDATE_ASYNC(pos, a) SCM_MAKE_VALIDATE_MSG(pos, a, ASYNCP, "user async")
595
596 #define ASYNC_GOT_IT(X) (SCM_SMOB_FLAGS (X))
597 #define SET_ASYNC_GOT_IT(X, V) (SCM_SET_SMOB_FLAGS ((X), ((V))))
598 #define ASYNC_THUNK(X) SCM_SMOB_OBJECT_1 (X)
599
600
601 SCM_DEFINE (scm_async, "async", 1, 0, 0,
602 (SCM thunk),
603 "Create a new async for the procedure @var{thunk}.")
604 #define FUNC_NAME s_scm_async
605 {
606 scm_c_issue_deprecation_warning
607 ("\"User asyncs\" are deprecated. Use closures instead.");
608
609 SCM_RETURN_NEWSMOB (tc16_async, SCM_UNPACK (thunk));
610 }
611 #undef FUNC_NAME
612
613 SCM_DEFINE (scm_async_mark, "async-mark", 1, 0, 0,
614 (SCM a),
615 "Mark the async @var{a} for future execution.")
616 #define FUNC_NAME s_scm_async_mark
617 {
618 VALIDATE_ASYNC (1, a);
619 SET_ASYNC_GOT_IT (a, 1);
620 return SCM_UNSPECIFIED;
621 }
622 #undef FUNC_NAME
623
624 SCM_DEFINE (scm_run_asyncs, "run-asyncs", 1, 0, 0,
625 (SCM list_of_a),
626 "Execute all thunks from the asyncs of the list @var{list_of_a}.")
627 #define FUNC_NAME s_scm_run_asyncs
628 {
629 while (! SCM_NULL_OR_NIL_P (list_of_a))
630 {
631 SCM a;
632 SCM_VALIDATE_CONS (1, list_of_a);
633 a = SCM_CAR (list_of_a);
634 VALIDATE_ASYNC (SCM_ARG1, a);
635 if (ASYNC_GOT_IT (a))
636 {
637 SET_ASYNC_GOT_IT (a, 0);
638 scm_call_0 (ASYNC_THUNK (a));
639 }
640 list_of_a = SCM_CDR (list_of_a);
641 }
642 return SCM_BOOL_T;
643 }
644 #undef FUNC_NAME
645
646
647 static scm_i_pthread_mutex_t critical_section_mutex;
648 static SCM dynwind_critical_section_mutex;
649
650 void
scm_critical_section_start(void)651 scm_critical_section_start (void)
652 {
653 scm_c_issue_deprecation_warning
654 ("Critical sections are deprecated. Instead use dynwinds and "
655 "\"scm_dynwind_pthread_mutex_lock\" together with "
656 "\"scm_dynwind_block_asyncs\" if appropriate.");
657
658 scm_i_pthread_mutex_lock (&critical_section_mutex);
659 SCM_I_CURRENT_THREAD->block_asyncs++;
660 }
661
662 void
scm_critical_section_end(void)663 scm_critical_section_end (void)
664 {
665 SCM_I_CURRENT_THREAD->block_asyncs--;
666 scm_i_pthread_mutex_unlock (&critical_section_mutex);
667 scm_async_tick ();
668 }
669
670 void
scm_dynwind_critical_section(SCM mutex)671 scm_dynwind_critical_section (SCM mutex)
672 {
673 scm_c_issue_deprecation_warning
674 ("Critical sections are deprecated. Instead use dynwinds and "
675 "\"scm_dynwind_pthread_mutex_lock\" together with "
676 "\"scm_dynwind_block_asyncs\" if appropriate.");
677
678 if (scm_is_false (mutex))
679 mutex = dynwind_critical_section_mutex;
680 scm_dynwind_lock_mutex (mutex);
681 scm_dynwind_block_asyncs ();
682 }
683
684
685
686
687 SCM
scm_make_mutex_with_flags(SCM flags)688 scm_make_mutex_with_flags (SCM flags)
689 {
690 SCM kind = SCM_UNDEFINED;
691
692 scm_c_issue_deprecation_warning
693 ("'scm_make_mutex_with_flags' is deprecated. "
694 "Use 'scm_make_mutex_with_kind' instead.");
695
696 if (!scm_is_null (flags))
697 {
698 if (!scm_is_null (scm_cdr (flags)))
699 scm_misc_error (NULL, "too many mutex options: ~a", scm_list_1 (flags));
700 kind = scm_car (flags);
701 }
702
703 return scm_make_mutex_with_kind (kind);
704 }
705
706 SCM
scm_lock_mutex_timed(SCM m,SCM timeout,SCM owner)707 scm_lock_mutex_timed (SCM m, SCM timeout, SCM owner)
708 {
709 scm_c_issue_deprecation_warning
710 ("'scm_lock_mutex_timed' is deprecated. "
711 "Use 'scm_timed_lock_mutex' instead.");
712
713 if (!SCM_UNBNDP (owner) && !scm_is_false (owner))
714 scm_c_issue_deprecation_warning
715 ("The 'owner' argument to 'scm_lock_mutex_timed' is deprecated. "
716 "Use SRFI-18 directly if you need this concept.");
717
718 return scm_timed_lock_mutex (m, timeout);
719 }
720
721 SCM
scm_unlock_mutex_timed(SCM mx,SCM cond,SCM timeout)722 scm_unlock_mutex_timed (SCM mx, SCM cond, SCM timeout)
723 {
724 scm_c_issue_deprecation_warning
725 ("'scm_unlock_mutex_timed' is deprecated. "
726 "Use just plain old 'scm_unlock_mutex' instead, or otherwise "
727 "'scm_wait_condition_variable' if you need to.");
728
729 if (!SCM_UNBNDP (cond) &&
730 scm_is_false (scm_timed_wait_condition_variable (cond, mx, timeout)))
731 return SCM_BOOL_F;
732
733 return scm_unlock_mutex (mx);
734 }
735
736
737
738 SCM
scm_from_contiguous_array(SCM bounds,const SCM * elts,size_t len)739 scm_from_contiguous_array (SCM bounds, const SCM *elts, size_t len)
740 #define FUNC_NAME "scm_from_contiguous_array"
741 {
742 size_t k, rlen = 1;
743 scm_t_array_dim *s;
744 SCM ra;
745 scm_t_array_handle h;
746
747 scm_c_issue_deprecation_warning
748 ("`scm_from_contiguous_array' is deprecated. Use make-array and array-copy!\n"
749 "instead.\n");
750
751 ra = scm_i_shap2ra (bounds);
752 SCM_SET_ARRAY_CONTIGUOUS_FLAG (ra);
753 s = SCM_I_ARRAY_DIMS (ra);
754 k = SCM_I_ARRAY_NDIM (ra);
755
756 while (k--)
757 {
758 s[k].inc = rlen;
759 SCM_ASSERT_RANGE (1, bounds, s[k].lbnd <= s[k].ubnd + 1);
760 rlen = (s[k].ubnd - s[k].lbnd + 1) * s[k].inc;
761 }
762 if (rlen != len)
763 SCM_MISC_ERROR ("element length and dimensions do not match", SCM_EOL);
764
765 SCM_I_ARRAY_SET_V (ra, scm_c_make_vector (rlen, SCM_UNDEFINED));
766 scm_array_get_handle (ra, &h);
767 memcpy (h.writable_elements, elts, rlen * sizeof(SCM));
768 scm_array_handle_release (&h);
769
770 if (1 == SCM_I_ARRAY_NDIM (ra) && 0 == SCM_I_ARRAY_BASE (ra))
771 if (0 == s->lbnd)
772 return SCM_I_ARRAY_V (ra);
773 return ra;
774 }
775 #undef FUNC_NAME
776
777
778
779 /* {call-with-dynamic-root}
780 *
781 * Suspending the current thread to evaluate a thunk on the
782 * same C stack but under a new root.
783 *
784 * Calls to call-with-dynamic-root return exactly once (unless
785 * the process is somehow exitted). */
786
787 /* cwdr fills out both of these structures, and then passes a pointer
788 to them through scm_internal_catch to the cwdr_body and
789 cwdr_handler functions, to tell them how to behave and to get
790 information back from them.
791
792 A cwdr is a lot like a catch, except there is no tag (all
793 exceptions are caught), and the body procedure takes the arguments
794 passed to cwdr as A1 and ARGS. The handler is also special since
795 it is not directly run from scm_internal_catch. It is executed
796 outside the new dynamic root. */
797
798 struct cwdr_body_data {
799 /* Arguments to pass to the cwdr body function. */
800 SCM a1, args;
801
802 /* Scheme procedure to use as body of cwdr. */
803 SCM body_proc;
804 };
805
806 struct cwdr_handler_data {
807 /* Do we need to run the handler? */
808 int run_handler;
809
810 /* The tag and args to pass it. */
811 SCM tag, args;
812 };
813
814
815 /* Invoke the body of a cwdr, assuming that the throw handler has
816 already been set up. DATA points to a struct set up by cwdr that
817 says what proc to call, and what args to apply it to.
818
819 With a little thought, we could replace this with scm_body_thunk,
820 but I don't want to mess with that at the moment. */
821 static SCM
cwdr_body(void * data)822 cwdr_body (void *data)
823 {
824 struct cwdr_body_data *c = (struct cwdr_body_data *) data;
825
826 return scm_apply (c->body_proc, c->a1, c->args);
827 }
828
829 /* Record the fact that the body of the cwdr has thrown. Record
830 enough information to invoke the handler later when the dynamic
831 root has been deestablished. */
832
833 static SCM
cwdr_handler(void * data,SCM tag,SCM args)834 cwdr_handler (void *data, SCM tag, SCM args)
835 {
836 struct cwdr_handler_data *c = (struct cwdr_handler_data *) data;
837
838 c->run_handler = 1;
839 c->tag = tag;
840 c->args = args;
841 return SCM_UNSPECIFIED;
842 }
843
844 SCM
scm_internal_cwdr(scm_t_catch_body body,void * body_data,scm_t_catch_handler handler,void * handler_data,SCM_STACKITEM * stack_start)845 scm_internal_cwdr (scm_t_catch_body body, void *body_data,
846 scm_t_catch_handler handler, void *handler_data,
847 SCM_STACKITEM *stack_start)
848 {
849 struct cwdr_handler_data my_handler_data;
850 scm_t_dynstack *dynstack = &SCM_I_CURRENT_THREAD->dynstack;
851 SCM answer;
852 scm_t_dynstack *old_dynstack;
853
854 /* Exit caller's dynamic state.
855 */
856 old_dynstack = scm_dynstack_capture_all (dynstack);
857 scm_dynstack_unwind (dynstack, SCM_DYNSTACK_FIRST (dynstack));
858
859 scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
860 scm_dynwind_current_dynamic_state (scm_current_dynamic_state ());
861
862 my_handler_data.run_handler = 0;
863 answer = scm_i_with_continuation_barrier (body, body_data,
864 cwdr_handler, &my_handler_data,
865 NULL, NULL);
866
867 scm_dynwind_end ();
868
869 /* Enter caller's dynamic state.
870 */
871 scm_dynstack_wind (dynstack, SCM_DYNSTACK_FIRST (old_dynstack));
872
873 /* Now run the real handler iff the body did a throw. */
874 if (my_handler_data.run_handler)
875 return handler (handler_data, my_handler_data.tag, my_handler_data.args);
876 else
877 return answer;
878 }
879
880 /* The original CWDR for invoking Scheme code with a Scheme handler. */
881
882 static SCM
cwdr(SCM proc,SCM a1,SCM args,SCM handler,SCM_STACKITEM * stack_start)883 cwdr (SCM proc, SCM a1, SCM args, SCM handler, SCM_STACKITEM *stack_start)
884 {
885 struct cwdr_body_data c;
886
887 c.a1 = a1;
888 c.args = args;
889 c.body_proc = proc;
890
891 return scm_internal_cwdr (cwdr_body, &c,
892 scm_handle_by_proc, &handler,
893 stack_start);
894 }
895
896 SCM_DEFINE (scm_call_with_dynamic_root, "call-with-dynamic-root", 2, 0, 0,
897 (SCM thunk, SCM handler),
898 "Call @var{thunk} with a new dynamic state and within\n"
899 "a continuation barrier. The @var{handler} catches all\n"
900 "otherwise uncaught throws and executes within the same\n"
901 "dynamic context as @var{thunk}.")
902 #define FUNC_NAME s_scm_call_with_dynamic_root
903 {
904 SCM_STACKITEM stack_place;
905 scm_c_issue_deprecation_warning
906 ("call-with-dynamic-root is deprecated. There is no replacement.");
907 return cwdr (thunk, SCM_EOL, SCM_EOL, handler, &stack_place);
908 }
909 #undef FUNC_NAME
910
911 SCM_DEFINE (scm_dynamic_root, "dynamic-root", 0, 0, 0,
912 (),
913 "Return an object representing the current dynamic root.\n\n"
914 "These objects are only useful for comparison using @code{eq?}.\n")
915 #define FUNC_NAME s_scm_dynamic_root
916 {
917 scm_c_issue_deprecation_warning
918 ("dynamic-root is deprecated. There is no replacement.");
919 return SCM_I_CURRENT_THREAD->continuation_root;
920 }
921 #undef FUNC_NAME
922
923 SCM
scm_apply_with_dynamic_root(SCM proc,SCM a1,SCM args,SCM handler)924 scm_apply_with_dynamic_root (SCM proc, SCM a1, SCM args, SCM handler)
925 {
926 SCM_STACKITEM stack_place;
927 scm_c_issue_deprecation_warning
928 ("scm_apply_with_dynamic_root is deprecated. There is no replacement.");
929 return cwdr (proc, a1, args, handler, &stack_place);
930 }
931
932
933
934
935 SCM
scm_make_dynamic_state(SCM parent)936 scm_make_dynamic_state (SCM parent)
937 {
938 scm_c_issue_deprecation_warning
939 ("scm_make_dynamic_state is deprecated. Dynamic states are "
940 "now immutable; just use the parent directly.");
941 return SCM_UNBNDP (parent) ? scm_current_dynamic_state () : parent;
942 }
943
944
945
946
947 int
SCM_FDES_RANDOM_P(int fdes)948 SCM_FDES_RANDOM_P (int fdes)
949 {
950 scm_c_issue_deprecation_warning
951 ("SCM_FDES_RANDOM_P is deprecated. Use lseek (fd, 0, SEEK_CUR).");
952
953 return (lseek (fdes, 0, SEEK_CUR) == -1) ? 0 : 1;
954 }
955
956
957
958 SCM_DEFINE (scm_make_struct, "make-struct", 2, 0, 1,
959 (SCM vtable, SCM tail_array_size, SCM init),
960 "Create a new structure.\n\n"
961 "@var{vtable} must be a vtable structure (@pxref{Vtables}).\n\n"
962 "@var{tail_array_size} must be a non-negative integer. If the layout\n"
963 "specification indicated by @var{vtable} includes a tail-array,\n"
964 "this is the number of elements allocated to that array.\n\n"
965 "The @var{init1}, @dots{} are optional arguments describing how\n"
966 "successive fields of the structure should be initialized. Only fields\n"
967 "with protection 'r' or 'w' can be initialized, except for fields of\n"
968 "type 's', which are automatically initialized to point to the new\n"
969 "structure itself. Fields with protection 'o' can not be initialized by\n"
970 "Scheme programs.\n\n"
971 "If fewer optional arguments than initializable fields are supplied,\n"
972 "fields of type 'p' get default value #f while fields of type 'u' are\n"
973 "initialized to 0.")
974 #define FUNC_NAME s_scm_make_struct
975 {
976 size_t i, n_init;
977 long ilen;
978 scm_t_bits *v;
979
980 scm_c_issue_deprecation_warning
981 ("make-struct is deprecated. Use make-struct/no-tail instead.");
982
983 SCM_VALIDATE_VTABLE (1, vtable);
984 ilen = scm_ilength (init);
985 if (ilen < 0)
986 SCM_MISC_ERROR ("Rest arguments do not form a proper list.", SCM_EOL);
987
988 n_init = (size_t)ilen;
989
990 /* best to use alloca, but init could be big, so hack to avoid a possible
991 stack overflow */
992 if (n_init < 64)
993 v = alloca (n_init * sizeof(scm_t_bits));
994 else
995 v = scm_gc_malloc (n_init * sizeof(scm_t_bits), "struct");
996
997 for (i = 0; i < n_init; i++, init = SCM_CDR (init))
998 v[i] = SCM_UNPACK (SCM_CAR (init));
999
1000 return scm_c_make_structv (vtable, scm_to_size_t (tail_array_size), n_init, v);
1001 }
1002 #undef FUNC_NAME
1003
1004
1005
1006 void
scm_i_init_deprecated()1007 scm_i_init_deprecated ()
1008 {
1009 scm_tc16_arbiter = scm_make_smob_type ("arbiter", 0);
1010 scm_set_smob_print (scm_tc16_arbiter, arbiter_print);
1011 tc16_async = scm_make_smob_type ("async", 0);
1012 scm_i_pthread_mutex_init (&critical_section_mutex,
1013 scm_i_pthread_mutexattr_recursive);
1014 dynwind_critical_section_mutex = scm_make_recursive_mutex ();
1015 #include "libguile/deprecated.x"
1016 }
1017
1018 #endif
1019