deprecated.c 16 KB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497
  1. /* This file contains definitions for deprecated features. When you
  2. deprecate something, move it here when that is feasible.
  3. */
  4. /* Copyright (C) 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
  5. *
  6. * This library is free software; you can redistribute it and/or
  7. * modify it under the terms of the GNU Lesser General Public License
  8. * as published by the Free Software Foundation; either version 3 of
  9. * the License, or (at your option) any later version.
  10. *
  11. * This library is distributed in the hope that it will be useful, but
  12. * WITHOUT ANY WARRANTY; without even the implied warranty of
  13. * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
  14. * Lesser General Public License for more details.
  15. *
  16. * You should have received a copy of the GNU Lesser General Public
  17. * License along with this library; if not, write to the Free Software
  18. * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
  19. * 02110-1301 USA
  20. */
  21. #ifdef HAVE_CONFIG_H
  22. # include <config.h>
  23. #endif
  24. #define SCM_BUILDING_DEPRECATED_CODE
  25. #include "libguile/_scm.h"
  26. #include "libguile/deprecation.h"
  27. #if (SCM_ENABLE_DEPRECATED == 1)
  28. SCM
  29. scm_internal_dynamic_wind (scm_t_guard before,
  30. scm_t_inner inner,
  31. scm_t_guard after,
  32. void *inner_data,
  33. void *guard_data)
  34. {
  35. SCM ans;
  36. scm_c_issue_deprecation_warning
  37. ("`scm_internal_dynamic_wind' is deprecated. "
  38. "Use the `scm_dynwind_begin' / `scm_dynwind_end' API instead.");
  39. scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
  40. scm_dynwind_rewind_handler (before, guard_data, SCM_F_WIND_EXPLICITLY);
  41. scm_dynwind_unwind_handler (after, guard_data, SCM_F_WIND_EXPLICITLY);
  42. ans = inner (inner_data);
  43. scm_dynwind_end ();
  44. return ans;
  45. }
  46. SCM
  47. scm_immutable_cell (scm_t_bits car, scm_t_bits cdr)
  48. {
  49. scm_c_issue_deprecation_warning
  50. ("scm_immutable_cell is deprecated. Use scm_cell instead.");
  51. return scm_cell (car, cdr);
  52. }
  53. SCM
  54. scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
  55. scm_t_bits ccr, scm_t_bits cdr)
  56. {
  57. scm_c_issue_deprecation_warning
  58. ("scm_immutable_double_cell is deprecated. Use scm_double_cell instead.");
  59. return scm_double_cell (car, cbr, ccr, cdr);
  60. }
  61. SCM_GLOBAL_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
  62. void
  63. scm_memory_error (const char *subr)
  64. {
  65. scm_c_issue_deprecation_warning
  66. ("scm_memory_error is deprecated. Use scm_report_out_of_memory to raise "
  67. "an exception, or abort() to cause the program to exit.");
  68. fprintf (stderr, "FATAL: memory error in %s\n", subr);
  69. abort ();
  70. }
  71. static SCM var_slot_ref_using_class = SCM_BOOL_F;
  72. static SCM var_slot_set_using_class_x = SCM_BOOL_F;
  73. static SCM var_slot_bound_using_class_p = SCM_BOOL_F;
  74. static SCM var_slot_exists_using_class_p = SCM_BOOL_F;
  75. SCM scm_no_applicable_method = SCM_BOOL_F;
  76. SCM var_get_keyword = SCM_BOOL_F;
  77. SCM scm_class_boolean, scm_class_char, scm_class_pair;
  78. SCM scm_class_procedure, scm_class_string, scm_class_symbol;
  79. SCM scm_class_primitive_generic;
  80. SCM scm_class_vector, scm_class_null;
  81. SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction;
  82. SCM scm_class_unknown;
  83. SCM scm_class_top, scm_class_object, scm_class_class;
  84. SCM scm_class_applicable;
  85. SCM scm_class_applicable_struct, scm_class_applicable_struct_with_setter;
  86. SCM scm_class_generic, scm_class_generic_with_setter;
  87. SCM scm_class_accessor;
  88. SCM scm_class_extended_generic, scm_class_extended_generic_with_setter;
  89. SCM scm_class_extended_accessor;
  90. SCM scm_class_method;
  91. SCM scm_class_accessor_method;
  92. SCM scm_class_procedure_class;
  93. SCM scm_class_applicable_struct_class;
  94. SCM scm_class_number, scm_class_list;
  95. SCM scm_class_keyword;
  96. SCM scm_class_port, scm_class_input_output_port;
  97. SCM scm_class_input_port, scm_class_output_port;
  98. SCM scm_class_foreign_slot;
  99. SCM scm_class_self, scm_class_protected;
  100. SCM scm_class_hidden, scm_class_opaque, scm_class_read_only;
  101. SCM scm_class_protected_hidden, scm_class_protected_opaque, scm_class_protected_read_only;
  102. SCM scm_class_scm;
  103. SCM scm_class_int, scm_class_float, scm_class_double;
  104. SCM *scm_port_class, *scm_smob_class;
  105. void
  106. scm_init_deprecated_goops (void)
  107. {
  108. var_slot_ref_using_class = scm_c_lookup ("slot-ref-using-class");
  109. var_slot_set_using_class_x = scm_c_lookup ("slot-set-using-class!");
  110. var_slot_bound_using_class_p = scm_c_lookup ("slot-bound-using-class?");
  111. var_slot_exists_using_class_p = scm_c_lookup ("slot-exists-using-class?");
  112. scm_no_applicable_method =
  113. scm_variable_ref (scm_c_lookup ("no-applicable-method"));
  114. var_get_keyword = scm_c_lookup ("get-keyword");
  115. scm_class_class = scm_variable_ref (scm_c_lookup ("<class>"));
  116. scm_class_top = scm_variable_ref (scm_c_lookup ("<top>"));
  117. scm_class_object = scm_variable_ref (scm_c_lookup ("<object>"));
  118. scm_class_foreign_slot = scm_variable_ref (scm_c_lookup ("<foreign-slot>"));
  119. scm_class_protected = scm_variable_ref (scm_c_lookup ("<protected-slot>"));
  120. scm_class_hidden = scm_variable_ref (scm_c_lookup ("<hidden-slot>"));
  121. scm_class_opaque = scm_variable_ref (scm_c_lookup ("<opaque-slot>"));
  122. scm_class_read_only = scm_variable_ref (scm_c_lookup ("<read-only-slot>"));
  123. scm_class_self = scm_variable_ref (scm_c_lookup ("<self-slot>"));
  124. scm_class_protected_opaque = scm_variable_ref (scm_c_lookup ("<protected-opaque-slot>"));
  125. scm_class_protected_hidden = scm_variable_ref (scm_c_lookup ("<protected-hidden-slot>"));
  126. scm_class_protected_read_only = scm_variable_ref (scm_c_lookup ("<protected-read-only-slot>"));
  127. scm_class_scm = scm_variable_ref (scm_c_lookup ("<scm-slot>"));
  128. scm_class_int = scm_variable_ref (scm_c_lookup ("<int-slot>"));
  129. scm_class_float = scm_variable_ref (scm_c_lookup ("<float-slot>"));
  130. scm_class_double = scm_variable_ref (scm_c_lookup ("<double-slot>"));
  131. /* scm_class_generic functions classes */
  132. scm_class_procedure_class = scm_variable_ref (scm_c_lookup ("<procedure-class>"));
  133. scm_class_applicable_struct_class = scm_variable_ref (scm_c_lookup ("<applicable-struct-class>"));
  134. scm_class_method = scm_variable_ref (scm_c_lookup ("<method>"));
  135. scm_class_accessor_method = scm_variable_ref (scm_c_lookup ("<accessor-method>"));
  136. scm_class_applicable = scm_variable_ref (scm_c_lookup ("<applicable>"));
  137. scm_class_applicable_struct = scm_variable_ref (scm_c_lookup ("<applicable-struct>"));
  138. scm_class_applicable_struct_with_setter = scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter>"));
  139. scm_class_generic = scm_variable_ref (scm_c_lookup ("<generic>"));
  140. scm_class_extended_generic = scm_variable_ref (scm_c_lookup ("<extended-generic>"));
  141. scm_class_generic_with_setter = scm_variable_ref (scm_c_lookup ("<generic-with-setter>"));
  142. scm_class_accessor = scm_variable_ref (scm_c_lookup ("<accessor>"));
  143. scm_class_extended_generic_with_setter = scm_variable_ref (scm_c_lookup ("<extended-generic-with-setter>"));
  144. scm_class_extended_accessor = scm_variable_ref (scm_c_lookup ("<extended-accessor>"));
  145. /* Primitive types classes */
  146. scm_class_boolean = scm_variable_ref (scm_c_lookup ("<boolean>"));
  147. scm_class_char = scm_variable_ref (scm_c_lookup ("<char>"));
  148. scm_class_list = scm_variable_ref (scm_c_lookup ("<list>"));
  149. scm_class_pair = scm_variable_ref (scm_c_lookup ("<pair>"));
  150. scm_class_null = scm_variable_ref (scm_c_lookup ("<null>"));
  151. scm_class_string = scm_variable_ref (scm_c_lookup ("<string>"));
  152. scm_class_symbol = scm_variable_ref (scm_c_lookup ("<symbol>"));
  153. scm_class_vector = scm_variable_ref (scm_c_lookup ("<vector>"));
  154. scm_class_number = scm_variable_ref (scm_c_lookup ("<number>"));
  155. scm_class_complex = scm_variable_ref (scm_c_lookup ("<complex>"));
  156. scm_class_real = scm_variable_ref (scm_c_lookup ("<real>"));
  157. scm_class_integer = scm_variable_ref (scm_c_lookup ("<integer>"));
  158. scm_class_fraction = scm_variable_ref (scm_c_lookup ("<fraction>"));
  159. scm_class_keyword = scm_variable_ref (scm_c_lookup ("<keyword>"));
  160. scm_class_unknown = scm_variable_ref (scm_c_lookup ("<unknown>"));
  161. scm_class_procedure = scm_variable_ref (scm_c_lookup ("<procedure>"));
  162. scm_class_primitive_generic = scm_variable_ref (scm_c_lookup ("<primitive-generic>"));
  163. scm_class_port = scm_variable_ref (scm_c_lookup ("<port>"));
  164. scm_class_input_port = scm_variable_ref (scm_c_lookup ("<input-port>"));
  165. scm_class_output_port = scm_variable_ref (scm_c_lookup ("<output-port>"));
  166. scm_class_input_output_port = scm_variable_ref (scm_c_lookup ("<input-output-port>"));
  167. scm_smob_class = scm_i_smob_class;
  168. }
  169. SCM
  170. scm_get_keyword (SCM kw, SCM initargs, SCM default_value)
  171. {
  172. scm_c_issue_deprecation_warning
  173. ("scm_get_keyword is deprecated. Use `kw-arg-ref' from Scheme instead.");
  174. return scm_call_3 (scm_variable_ref (var_get_keyword),
  175. kw, initargs, default_value);
  176. }
  177. #define BUFFSIZE 32 /* big enough for most uses */
  178. #define SPEC_OF(x) \
  179. (scm_slot_ref (x, scm_slot_ref (x, scm_from_latin1_symbol ("specializers"))))
  180. #define CPL_OF(x) \
  181. (scm_slot_ref (x, scm_slot_ref (x, scm_from_latin1_symbol ("cpl"))))
  182. static SCM
  183. scm_i_vector2list (SCM l, long len)
  184. {
  185. long j;
  186. SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
  187. for (j = 0; j < len; j++, l = SCM_CDR (l)) {
  188. SCM_SIMPLE_VECTOR_SET (z, j, SCM_CAR (l));
  189. }
  190. return z;
  191. }
  192. static int
  193. applicablep (SCM actual, SCM formal)
  194. {
  195. /* We already know that the cpl is well formed. */
  196. return scm_is_true (scm_c_memq (formal, CPL_OF (actual)));
  197. }
  198. static int
  199. more_specificp (SCM m1, SCM m2, SCM const *targs)
  200. {
  201. register SCM s1, s2;
  202. register long i;
  203. /*
  204. * Note:
  205. * m1 and m2 can have != length (i.e. one can be one element longer than the
  206. * other when we have a dotted parameter list). For instance, with the call
  207. * (M 1)
  208. * with
  209. * (define-method M (a . l) ....)
  210. * (define-method M (a) ....)
  211. *
  212. * we consider that the second method is more specific.
  213. *
  214. * BTW, targs is an array of types. We don't need it's size since
  215. * we already know that m1 and m2 are applicable (no risk to go past
  216. * the end of this array).
  217. *
  218. */
  219. for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) {
  220. if (scm_is_null(s1)) return 1;
  221. if (scm_is_null(s2)) return 0;
  222. if (!scm_is_eq (SCM_CAR(s1), SCM_CAR(s2))) {
  223. register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
  224. for (l = CPL_OF (targs[i]); ; l = SCM_CDR(l)) {
  225. if (scm_is_eq (cs1, SCM_CAR (l)))
  226. return 1;
  227. if (scm_is_eq (cs2, SCM_CAR (l)))
  228. return 0;
  229. }
  230. return 0;/* should not occur! */
  231. }
  232. }
  233. return 0; /* should not occur! */
  234. }
  235. static SCM
  236. sort_applicable_methods (SCM method_list, long size, SCM const *targs)
  237. {
  238. long i, j, incr;
  239. SCM *v, vector = SCM_EOL;
  240. SCM buffer[BUFFSIZE];
  241. SCM save = method_list;
  242. scm_t_array_handle handle;
  243. /* For reasonably sized method_lists we can try to avoid all the
  244. * consing and reorder the list in place...
  245. * This idea is due to David McClain <Dave_McClain@msn.com>
  246. */
  247. if (size <= BUFFSIZE)
  248. {
  249. for (i = 0; i < size; i++)
  250. {
  251. buffer[i] = SCM_CAR (method_list);
  252. method_list = SCM_CDR (method_list);
  253. }
  254. v = buffer;
  255. }
  256. else
  257. {
  258. /* Too many elements in method_list to keep everything locally */
  259. vector = scm_i_vector2list (save, size);
  260. v = scm_vector_writable_elements (vector, &handle, NULL, NULL);
  261. }
  262. /* Use a simple shell sort since it is generally faster than qsort on
  263. * small vectors (which is probably mostly the case when we have to
  264. * sort a list of applicable methods).
  265. */
  266. for (incr = size / 2; incr; incr /= 2)
  267. {
  268. for (i = incr; i < size; i++)
  269. {
  270. for (j = i - incr; j >= 0; j -= incr)
  271. {
  272. if (more_specificp (v[j], v[j+incr], targs))
  273. break;
  274. else
  275. {
  276. SCM tmp = v[j + incr];
  277. v[j + incr] = v[j];
  278. v[j] = tmp;
  279. }
  280. }
  281. }
  282. }
  283. if (size <= BUFFSIZE)
  284. {
  285. /* We did it in locally, so restore the original list (reordered) in-place */
  286. for (i = 0, method_list = save; i < size; i++, v++)
  287. {
  288. SCM_SETCAR (method_list, *v);
  289. method_list = SCM_CDR (method_list);
  290. }
  291. return save;
  292. }
  293. /* If we are here, that's that we did it the hard way... */
  294. scm_array_handle_release (&handle);
  295. return scm_vector_to_list (vector);
  296. }
  297. SCM
  298. scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
  299. {
  300. register long i;
  301. long count = 0;
  302. SCM l, fl, applicable = SCM_EOL;
  303. SCM save = args;
  304. SCM buffer[BUFFSIZE];
  305. SCM const *types;
  306. SCM *p;
  307. SCM tmp = SCM_EOL;
  308. scm_t_array_handle handle;
  309. scm_c_issue_deprecation_warning
  310. ("scm_compute_applicable_methods is deprecated. Use "
  311. "`compute-applicable-methods' from Scheme instead.");
  312. /* Build the list of arguments types */
  313. if (len >= BUFFSIZE)
  314. {
  315. tmp = scm_c_make_vector (len, SCM_UNDEFINED);
  316. types = p = scm_vector_writable_elements (tmp, &handle, NULL, NULL);
  317. /*
  318. note that we don't have to work to reset the generation
  319. count. TMP is a new vector anyway, and it is found
  320. conservatively.
  321. */
  322. }
  323. else
  324. types = p = buffer;
  325. for ( ; !scm_is_null (args); args = SCM_CDR (args))
  326. *p++ = scm_class_of (SCM_CAR (args));
  327. /* Build a list of all applicable methods */
  328. for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
  329. {
  330. fl = SPEC_OF (SCM_CAR (l));
  331. for (i = 0; ; i++, fl = SCM_CDR (fl))
  332. {
  333. if (SCM_INSTANCEP (fl)
  334. /* We have a dotted argument list */
  335. || (i >= len && scm_is_null (fl)))
  336. { /* both list exhausted */
  337. applicable = scm_cons (SCM_CAR (l), applicable);
  338. count += 1;
  339. break;
  340. }
  341. if (i >= len
  342. || scm_is_null (fl)
  343. || !applicablep (types[i], SCM_CAR (fl)))
  344. break;
  345. }
  346. }
  347. if (len >= BUFFSIZE)
  348. scm_array_handle_release (&handle);
  349. if (count == 0)
  350. {
  351. if (find_method_p)
  352. return SCM_BOOL_F;
  353. scm_call_2 (scm_no_applicable_method, gf, save);
  354. /* if we are here, it's because no-applicable-method hasn't signaled an error */
  355. return SCM_BOOL_F;
  356. }
  357. return (count == 1
  358. ? applicable
  359. : sort_applicable_methods (applicable, count, types));
  360. }
  361. SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
  362. SCM
  363. scm_find_method (SCM l)
  364. #define FUNC_NAME "find-method"
  365. {
  366. SCM gf;
  367. long len = scm_ilength (l);
  368. if (len == 0)
  369. SCM_WRONG_NUM_ARGS ();
  370. scm_c_issue_deprecation_warning
  371. ("scm_find_method is deprecated. Use `compute-applicable-methods' "
  372. "from Scheme instead.");
  373. gf = SCM_CAR(l); l = SCM_CDR(l);
  374. SCM_VALIDATE_GENERIC (1, gf);
  375. if (scm_is_null (scm_slot_ref (gf, scm_from_latin1_symbol ("methods"))))
  376. SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf));
  377. return scm_compute_applicable_methods (gf, l, len - 1, 1);
  378. }
  379. #undef FUNC_NAME
  380. SCM
  381. scm_basic_make_class (SCM meta, SCM name, SCM dsupers, SCM dslots)
  382. {
  383. scm_c_issue_deprecation_warning
  384. ("scm_basic_make_class is deprecated. Use `define-class' in Scheme,"
  385. "or use `(make META #:name NAME #:dsupers DSUPERS #:slots DSLOTS)' "
  386. "in Scheme.");
  387. return scm_make_standard_class (meta, name, dsupers, dslots);
  388. }
  389. /* Scheme will issue the deprecation warning for these. */
  390. SCM
  391. scm_slot_ref_using_class (SCM class, SCM obj, SCM slot_name)
  392. {
  393. return scm_call_3 (scm_variable_ref (var_slot_ref_using_class),
  394. class, obj, slot_name);
  395. }
  396. SCM
  397. scm_slot_set_using_class_x (SCM class, SCM obj, SCM slot_name, SCM value)
  398. {
  399. return scm_call_4 (scm_variable_ref (var_slot_set_using_class_x),
  400. class, obj, slot_name, value);
  401. }
  402. SCM
  403. scm_slot_bound_using_class_p (SCM class, SCM obj, SCM slot_name)
  404. {
  405. return scm_call_3 (scm_variable_ref (var_slot_bound_using_class_p),
  406. class, obj, slot_name);
  407. }
  408. SCM
  409. scm_slot_exists_using_class_p (SCM class, SCM obj, SCM slot_name)
  410. {
  411. return scm_call_3 (scm_variable_ref (var_slot_exists_using_class_p),
  412. class, obj, slot_name);
  413. }
  414. void
  415. scm_i_init_deprecated ()
  416. {
  417. #include "libguile/deprecated.x"
  418. }
  419. #endif