1 /* Copyright 2003-2004,2006,2008-2018,2020,2021
2 Free Software Foundation, Inc.
3
4 This file is part of Guile.
5
6 Guile is free software: you can redistribute it and/or modify it
7 under the terms of the GNU Lesser General Public License as published
8 by the Free Software Foundation, either version 3 of the License, or
9 (at your option) any later version.
10
11 Guile is distributed in the hope that it will be useful, but WITHOUT
12 ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
13 FITNESS FOR A PARTICULAR PURPOSE. See the GNU Lesser General Public
14 License for more details.
15
16 You should have received a copy of the GNU Lesser General Public
17 License along with Guile. If not, see
18 <https://www.gnu.org/licenses/>. */
19
20 #ifdef HAVE_CONFIG_H
21 # include <config.h>
22 #endif
23
24 #include <stdio.h>
25 #include <string.h>
26 #include <unistd.h>
27
28 #define SCM_BUILDING_DEPRECATED_CODE
29
30 #include "alist.h"
31 #include "boolean.h"
32 #include "bitvectors.h"
33 #include "deprecation.h"
34 #include "dynl.h"
35 #include "eval.h"
36 #include "foreign.h"
37 #include "gc.h"
38 #include "gsubr.h"
39 #include "modules.h"
40 #include "procprop.h"
41 #include "srcprop.h"
42 #include "srfi-4.h"
43 #include "strings.h"
44 #include "symbols.h"
45
46 #include "deprecated.h"
47
48 #if (SCM_ENABLE_DEPRECATED == 1)
49
50
51
52 #ifndef MAXPATHLEN
53 #define MAXPATHLEN 80
54 #endif /* ndef MAXPATHLEN */
55 #ifndef X_OK
56 #define X_OK 1
57 #endif /* ndef X_OK */
58
59 char *
scm_find_executable(const char * name)60 scm_find_executable (const char *name)
61 {
62 char tbuf[MAXPATHLEN];
63 int i = 0, c;
64 FILE *f;
65
66 scm_c_issue_deprecation_warning ("scm_find_executable is deprecated.");
67
68 /* fprintf(stderr, "s_f_e checking access %s ->%d\n", name, access(name, X_OK)); fflush(stderr); */
69 if (access (name, X_OK))
70 return 0L;
71 f = fopen (name, "r");
72 if (!f)
73 return 0L;
74 if ((fgetc (f) == '#') && (fgetc (f) == '!'))
75 {
76 while (1)
77 switch (c = fgetc (f))
78 {
79 case /*WHITE_SPACES */ ' ':
80 case '\t':
81 case '\r':
82 case '\f':
83 case EOF:
84 tbuf[i] = 0;
85 fclose (f);
86 return strdup (tbuf);
87 default:
88 tbuf[i++] = c;
89 break;
90 }
91 }
92 fclose (f);
93 return strdup (name);
94 }
95
96
97
98
99 SCM
scm_bitvector_p(SCM vec)100 scm_bitvector_p (SCM vec)
101 {
102 scm_c_issue_deprecation_warning
103 ("scm_bitvector_p is deprecated. Use scm_is_bitvector instead.");
104
105 return scm_from_bool (scm_is_bitvector (vec));
106 }
107
108 SCM
scm_bitvector(SCM list)109 scm_bitvector (SCM list)
110 {
111 scm_c_issue_deprecation_warning
112 ("scm_bitvector is deprecated. Use scm_list_to_bitvector instead.");
113
114 return scm_list_to_bitvector (list);
115 }
116
117 SCM
scm_make_bitvector(SCM len,SCM fill)118 scm_make_bitvector (SCM len, SCM fill)
119 {
120 scm_c_issue_deprecation_warning
121 ("scm_make_bitvector is deprecated. Use scm_c_make_bitvector instead.");
122
123 return scm_c_make_bitvector (scm_to_size_t (len), fill);
124 }
125
126 SCM
scm_bitvector_length(SCM vec)127 scm_bitvector_length (SCM vec)
128 {
129 scm_c_issue_deprecation_warning
130 ("scm_bitvector_length is deprecated. Use scm_c_bitvector_length "
131 "instead.");
132
133 return scm_from_size_t (scm_c_bitvector_length (vec));
134 }
135
136 SCM
scm_c_bitvector_ref(SCM vec,size_t idx)137 scm_c_bitvector_ref (SCM vec, size_t idx)
138 {
139 scm_c_issue_deprecation_warning
140 ("bitvector-ref is deprecated. Use bitvector-bit-set? instead.");
141
142 if (scm_is_bitvector (vec))
143 return scm_from_bool (scm_c_bitvector_bit_is_set (vec, idx));
144
145 SCM res;
146 scm_t_array_handle handle;
147 size_t len, off;
148 ssize_t inc;
149
150 const uint32_t *bits =
151 scm_bitvector_elements (vec, &handle, &off, &len, &inc);
152
153 if (idx >= len)
154 scm_out_of_range (NULL, scm_from_size_t (idx));
155 idx = idx*inc + off;
156 res = scm_from_bool (bits[idx/32] & (1L << (idx%32)));
157 scm_array_handle_release (&handle);
158 return res;
159 }
160
161 SCM_DEFINE (scm_bitvector_ref, "bitvector-ref", 2, 0, 0,
162 (SCM vec, SCM idx),
163 "Return the element at index @var{idx} of the bitvector\n"
164 "@var{vec}.")
165 #define FUNC_NAME s_scm_bitvector_ref
166 {
167 return scm_c_bitvector_ref (vec, scm_to_size_t (idx));
168 }
169 #undef FUNC_NAME
170
171 void
scm_c_bitvector_set_x(SCM vec,size_t idx,SCM val)172 scm_c_bitvector_set_x (SCM vec, size_t idx, SCM val)
173 {
174 scm_c_issue_deprecation_warning
175 ("bitvector-set! is deprecated. Use bitvector-set-bit! or "
176 "bitvector-clear-bit! instead.");
177
178 if (scm_is_bitvector (vec))
179 {
180 if (scm_is_true (val))
181 scm_c_bitvector_set_bit_x (vec, idx);
182 else
183 scm_c_bitvector_clear_bit_x (vec, idx);
184 }
185 else
186 {
187 scm_t_array_handle handle;
188 uint32_t *bits, mask;
189 size_t len, off;
190 ssize_t inc;
191
192 bits = scm_bitvector_writable_elements (vec, &handle, &off, &len, &inc);
193 if (idx >= len)
194 scm_out_of_range (NULL, scm_from_size_t (idx));
195 idx = idx*inc + off;
196
197 mask = 1L << (idx%32);
198 if (scm_is_true (val))
199 bits[idx/32] |= mask;
200 else
201 bits[idx/32] &= ~mask;
202
203 scm_array_handle_release (&handle);
204 }
205 }
206
207 SCM_DEFINE (scm_bitvector_set_x, "bitvector-set!", 3, 0, 0,
208 (SCM vec, SCM idx, SCM val),
209 "Set the element at index @var{idx} of the bitvector\n"
210 "@var{vec} when @var{val} is true, else clear it.")
211 #define FUNC_NAME s_scm_bitvector_set_x
212 {
213 scm_c_bitvector_set_x (vec, scm_to_size_t (idx), val);
214 return SCM_UNSPECIFIED;
215 }
216 #undef FUNC_NAME
217
218 SCM_DEFINE (scm_bitvector_fill_x, "bitvector-fill!", 2, 0, 0,
219 (SCM vec, SCM val),
220 "Set all elements of the bitvector\n"
221 "@var{vec} when @var{val} is true, else clear them.")
222 #define FUNC_NAME s_scm_bitvector_fill_x
223 {
224 scm_c_issue_deprecation_warning
225 ("bitvector-fill! is deprecated. Use bitvector-set-all-bits! or "
226 "bitvector-clear-all-bits! instead.");
227
228 if (scm_is_bitvector (vec))
229 {
230 if (scm_is_true (val))
231 scm_c_bitvector_set_all_bits_x (vec);
232 else
233 scm_c_bitvector_clear_all_bits_x (vec);
234
235 return SCM_UNSPECIFIED;
236 }
237
238 scm_t_array_handle handle;
239 size_t off, len;
240 ssize_t inc;
241
242 scm_bitvector_writable_elements (vec, &handle, &off, &len, &inc);
243
244 size_t i;
245 for (i = 0; i < len; i++)
246 scm_array_handle_set (&handle, i*inc, val);
247
248 scm_array_handle_release (&handle);
249
250 return SCM_UNSPECIFIED;
251 }
252 #undef FUNC_NAME
253
254 SCM_DEFINE (scm_bit_invert_x, "bit-invert!", 1, 0, 0,
255 (SCM v),
256 "Modify the bit vector @var{v} by replacing each element with\n"
257 "its negation.")
258 #define FUNC_NAME s_scm_bit_invert_x
259 {
260 scm_c_issue_deprecation_warning
261 ("bit-invert! is deprecated. Use bitvector-flip-all-bits!, or "
262 "scalar array accessors in a loop for generic arrays.");
263
264 if (scm_is_bitvector (v))
265 scm_c_bitvector_flip_all_bits_x (v);
266 else
267 {
268 size_t off, len;
269 ssize_t inc;
270 scm_t_array_handle handle;
271
272 scm_bitvector_writable_elements (v, &handle, &off, &len, &inc);
273 for (size_t i = 0; i < len; i++)
274 scm_array_handle_set (&handle, i*inc,
275 scm_not (scm_array_handle_ref (&handle, i*inc)));
276 scm_array_handle_release (&handle);
277 }
278
279 return SCM_UNSPECIFIED;
280 }
281 #undef FUNC_NAME
282
283 SCM_DEFINE (scm_bit_count, "bit-count", 2, 0, 0,
284 (SCM b, SCM bitvector),
285 "Return the number of occurrences of the boolean @var{b} in\n"
286 "@var{bitvector}.")
287 #define FUNC_NAME s_scm_bit_count
288 {
289 int bit = scm_to_bool (b);
290 size_t count = 0, len;
291
292 scm_c_issue_deprecation_warning
293 ("bit-count is deprecated. Use bitvector-count, or a loop over array-ref "
294 "if array support is needed.");
295
296 if (scm_is_bitvector (bitvector))
297 {
298 len = scm_to_size_t (scm_bitvector_length (bitvector));
299 count = scm_c_bitvector_count (bitvector);
300 }
301 else
302 {
303 scm_t_array_handle handle;
304 size_t off;
305 ssize_t inc;
306
307 scm_bitvector_elements (bitvector, &handle, &off, &len, &inc);
308
309 for (size_t i = 0; i < len; i++)
310 if (scm_is_true (scm_array_handle_ref (&handle, i*inc)))
311 count++;
312
313 scm_array_handle_release (&handle);
314 }
315
316 return scm_from_size_t (bit ? count : len-count);
317 }
318 #undef FUNC_NAME
319
320 SCM_DEFINE (scm_bit_count_star, "bit-count*", 3, 0, 0,
321 (SCM v, SCM kv, SCM obj),
322 "Return a count of how many entries in bit vector @var{v} are\n"
323 "equal to @var{obj}, with @var{kv} selecting the entries to\n"
324 "consider.\n"
325 "\n"
326 "If @var{kv} is a bit vector, then those entries where it has\n"
327 "@code{#t} are the ones in @var{v} which are considered.\n"
328 "@var{kv} and @var{v} must be the same length.\n"
329 "\n"
330 "If @var{kv} is a u32vector, then it contains\n"
331 "the indexes in @var{v} to consider.\n"
332 "\n"
333 "For example,\n"
334 "\n"
335 "@example\n"
336 "(bit-count* #*01110111 #*11001101 #t) @result{} 3\n"
337 "(bit-count* #*01110111 #u32(7 0 4) #f) @result{} 2\n"
338 "@end example")
339 #define FUNC_NAME s_scm_bit_count_star
340 {
341 size_t count = 0;
342
343 scm_c_issue_deprecation_warning
344 ("bit-count* is deprecated. Use bitvector-count-bits instead, and in the "
345 "case of counting false bits, subtract from a bitvector-count on the "
346 "selection bitvector.");
347
348 /* Validate that OBJ is a boolean so this is done even if we don't
349 need BIT.
350 */
351 int bit = scm_to_bool (obj);
352
353 if (scm_is_bitvector (v) && scm_is_bitvector (kv))
354 {
355 count = scm_c_bitvector_count_bits (v, kv);
356 if (count == 0)
357 count = scm_c_bitvector_count (kv) - count;
358 }
359 else
360 {
361 scm_t_array_handle v_handle;
362 size_t v_off, v_len;
363 ssize_t v_inc;
364
365 scm_bitvector_elements (v, &v_handle, &v_off, &v_len, &v_inc);
366
367 if (scm_is_bitvector (kv))
368 {
369 size_t kv_len = scm_c_bitvector_length (kv);
370 for (size_t i = 0; i < kv_len; i++)
371 if (scm_c_bitvector_bit_is_set (kv, i))
372 {
373 SCM elt = scm_array_handle_ref (&v_handle, i*v_inc);
374 if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
375 count++;
376 }
377 }
378 else if (scm_is_true (scm_u32vector_p (kv)))
379 {
380 scm_t_array_handle kv_handle;
381 size_t i, kv_len;
382 ssize_t kv_inc;
383 const uint32_t *kv_elts;
384
385 kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc);
386
387 for (i = 0; i < kv_len; i++, kv_elts += kv_inc)
388 {
389 SCM elt = scm_array_handle_ref (&v_handle, (*kv_elts)*v_inc);
390 if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
391 count++;
392 }
393
394 scm_array_handle_release (&kv_handle);
395 }
396 else
397 scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
398
399 scm_array_handle_release (&v_handle);
400 }
401
402 return scm_from_size_t (count);
403 }
404 #undef FUNC_NAME
405
406 SCM_DEFINE (scm_bit_position, "bit-position", 3, 0, 0,
407 (SCM item, SCM v, SCM k),
408 "Return the index of the first occurrence of @var{item} in bit\n"
409 "vector @var{v}, starting from @var{k}. If there is no\n"
410 "@var{item} entry between @var{k} and the end of\n"
411 "@var{v}, then return @code{#f}. For example,\n"
412 "\n"
413 "@example\n"
414 "(bit-position #t #*000101 0) @result{} 3\n"
415 "(bit-position #f #*0001111 3) @result{} #f\n"
416 "@end example")
417 #define FUNC_NAME s_scm_bit_position
418 {
419 scm_c_issue_deprecation_warning
420 ("bit-position is deprecated. Use bitvector-position, or "
421 "array-ref in a loop if you need generic arrays instead.");
422
423 if (scm_is_bitvector (v))
424 return scm_bitvector_position (v, item, k);
425
426 scm_t_array_handle handle;
427 size_t off, len;
428 ssize_t inc;
429 scm_bitvector_elements (v, &handle, &off, &len, &inc);
430 int bit = scm_to_bool (item);
431 size_t first_bit = scm_to_unsigned_integer (k, 0, len);
432 SCM res = SCM_BOOL_F;
433 for (size_t i = first_bit; i < len; i++)
434 {
435 SCM elt = scm_array_handle_ref (&handle, i*inc);
436 if ((bit && scm_is_true (elt)) || (!bit && scm_is_false (elt)))
437 {
438 res = scm_from_size_t (i);
439 break;
440 }
441 }
442 scm_array_handle_release (&handle);
443
444 return res;
445 }
446 #undef FUNC_NAME
447
448 SCM_DEFINE (scm_bit_set_star_x, "bit-set*!", 3, 0, 0,
449 (SCM v, SCM kv, SCM obj),
450 "Set entries of bit vector @var{v} to @var{obj}, with @var{kv}\n"
451 "selecting the entries to change. The return value is\n"
452 "unspecified.\n"
453 "\n"
454 "If @var{kv} is a bit vector, then those entries where it has\n"
455 "@code{#t} are the ones in @var{v} which are set to @var{obj}.\n"
456 "@var{v} must be at least as long as @var{kv}. When @var{obj}\n"
457 "is @code{#t} it's like @var{kv} is OR'ed into @var{v}. Or when\n"
458 "@var{obj} is @code{#f} it can be seen as an ANDNOT.\n"
459 "\n"
460 "@example\n"
461 "(define bv #*01000010)\n"
462 "(bit-set*! bv #*10010001 #t)\n"
463 "bv\n"
464 "@result{} #*11010011\n"
465 "@end example\n"
466 "\n"
467 "If @var{kv} is a u32vector, then its elements are\n"
468 "indices into @var{v} which are set to @var{obj}.\n"
469 "\n"
470 "@example\n"
471 "(define bv #*01000010)\n"
472 "(bit-set*! bv #u32(5 2 7) #t)\n"
473 "bv\n"
474 "@result{} #*01100111\n"
475 "@end example")
476 #define FUNC_NAME s_scm_bit_set_star_x
477 {
478 scm_c_issue_deprecation_warning
479 ("bit-set*! is deprecated. Use bitvector-set-bits! or "
480 "bitvector-clear-bits! on bitvectors, or array-set! in a loop "
481 "if you need to work on generic arrays.");
482
483 int bit = scm_to_bool (obj);
484 if (scm_is_bitvector (v) && scm_is_bitvector (kv))
485 {
486 if (bit)
487 scm_c_bitvector_set_bits_x (v, kv);
488 else
489 scm_c_bitvector_clear_bits_x (v, kv);
490
491 return SCM_UNSPECIFIED;
492 }
493
494 scm_t_array_handle v_handle;
495 size_t v_off, v_len;
496 ssize_t v_inc;
497 scm_bitvector_writable_elements (v, &v_handle, &v_off, &v_len, &v_inc);
498
499 if (scm_is_bitvector (kv))
500 {
501 size_t kv_len = scm_c_bitvector_length (kv);
502
503 if (v_len < kv_len)
504 scm_misc_error (NULL,
505 "selection bitvector longer than target bitvector",
506 SCM_EOL);
507
508 for (size_t i = 0; i < kv_len; i++)
509 if (scm_is_true (scm_c_bitvector_ref (kv, i)))
510 scm_array_handle_set (&v_handle, i*v_inc, obj);
511 }
512 else if (scm_is_true (scm_u32vector_p (kv)))
513 {
514 scm_t_array_handle kv_handle;
515 size_t kv_len;
516 ssize_t kv_inc;
517 const uint32_t *kv_elts;
518
519 kv_elts = scm_u32vector_elements (kv, &kv_handle, &kv_len, &kv_inc);
520 for (size_t i = 0; i < kv_len; i++, kv_elts += kv_inc)
521 scm_array_handle_set (&v_handle, (*kv_elts)*v_inc, obj);
522
523 scm_array_handle_release (&kv_handle);
524 }
525 else
526 scm_wrong_type_arg_msg (NULL, 0, kv, "bitvector or u32vector");
527
528 scm_array_handle_release (&v_handle);
529
530 return SCM_UNSPECIFIED;
531 }
532 #undef FUNC_NAME
533
534 SCM
scm_istr2bve(SCM str)535 scm_istr2bve (SCM str)
536 {
537 scm_t_array_handle handle;
538 size_t len = scm_i_string_length (str);
539 SCM vec = scm_c_make_bitvector (len, SCM_UNDEFINED);
540 SCM res = vec;
541
542 uint32_t mask;
543 size_t k, j;
544 const char *c_str;
545 uint32_t *data;
546
547 scm_c_issue_deprecation_warning
548 ("scm_istr2bve is deprecated. "
549 "Read from a string instead, prefixed with `#*'.");
550
551 data = scm_bitvector_writable_elements (vec, &handle, NULL, NULL, NULL);
552 c_str = scm_i_string_chars (str);
553
554 for (k = 0; k < (len + 31) / 32; k++)
555 {
556 data[k] = 0L;
557 j = len - k * 32;
558 if (j > 32)
559 j = 32;
560 for (mask = 1L; j--; mask <<= 1)
561 switch (*c_str++)
562 {
563 case '0':
564 break;
565 case '1':
566 data[k] |= mask;
567 break;
568 default:
569 res = SCM_BOOL_F;
570 goto exit;
571 }
572 }
573
574 exit:
575 scm_array_handle_release (&handle);
576 scm_remember_upto_here_1 (str);
577 return res;
578 }
579
580 SCM_GLOBAL_SYMBOL (scm_sym_copy, "copy");
581
582 SCM
scm_make_srcprops(long line,int col,SCM filename,SCM copy,SCM alist)583 scm_make_srcprops (long line, int col, SCM filename, SCM copy, SCM alist)
584 {
585 scm_c_issue_deprecation_warning
586 ("scm_make_srcprops is deprecated; use set-source-properties! instead");
587
588 alist = SCM_UNBNDP (copy) ? alist : scm_acons (scm_sym_copy, copy, alist);
589 return scm_i_make_srcprops (scm_from_long (line), scm_from_int (col),
590 filename, alist);
591 }
592
593 SCM
scm_copy_tree(SCM obj)594 scm_copy_tree (SCM obj)
595 {
596 scm_c_issue_deprecation_warning
597 ("scm_copy_tree is deprecated; use copy-tree from (ice-9 copy-tree) "
598 "instead.");
599
600 return scm_call_1 (scm_c_public_ref ("ice-9 copy-tree", "copy-tree"), obj);
601 }
602
603
604
605
606 SCM_DEFINE (scm_dynamic_unlink, "dynamic-unlink", 1, 0, 0, (SCM obj), "")
607 #define FUNC_NAME s_scm_dynamic_unlink
608 {
609 scm_c_issue_deprecation_warning
610 ("scm_dynamic_unlink has no effect and is deprecated. Unloading "
611 "shared libraries is no longer supported.");
612 return SCM_UNSPECIFIED;
613 }
614 #undef FUNC_NAME
615
616
617
618
619 void
scm_i_init_deprecated()620 scm_i_init_deprecated ()
621 {
622 #include "deprecated.x"
623 }
624
625 #endif /* SCM_ENABLE_DEPRECATD == 1 */
626