[bpt/guile.git] / libguile / deprecated.c

/* This file contains definitions for deprecated features.  When you
   deprecate something, move it here when that is feasible.
*/

/* Copyright (C) 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
 *
 * This library is free software; you can redistribute it and/or
 * modify it under the terms of the GNU Lesser General Public License
 * as published by the Free Software Foundation; either version 3 of
 * the License, or (at your option) any later version.
 *
 * This library is distributed in the hope that it will be useful, but
 * WITHOUT ANY WARRANTY; without even the implied warranty of
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
 * Lesser General Public License for more details.
 *
 * You should have received a copy of the GNU Lesser General Public
 * License along with this library; if not, write to the Free Software
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
 * 02110-1301 USA
 */

#ifdef HAVE_CONFIG_H
# include <config.h>
#endif

#define SCM_BUILDING_DEPRECATED_CODE

#include "libguile/_scm.h"
#include "libguile/deprecation.h"

#if (SCM_ENABLE_DEPRECATED == 1)

\f

SCM
scm_internal_dynamic_wind (scm_t_guard before,
			   scm_t_inner inner,
			   scm_t_guard after,
			   void *inner_data,
			   void *guard_data)
{
  SCM ans;

  scm_c_issue_deprecation_warning
    ("`scm_internal_dynamic_wind' is deprecated.  "
     "Use the `scm_dynwind_begin' / `scm_dynwind_end' API instead.");

  scm_dynwind_begin (SCM_F_DYNWIND_REWINDABLE);
  scm_dynwind_rewind_handler (before, guard_data, SCM_F_WIND_EXPLICITLY);
  scm_dynwind_unwind_handler (after, guard_data, SCM_F_WIND_EXPLICITLY);
  ans = inner (inner_data);
  scm_dynwind_end ();
  return ans;
}

\f

SCM
scm_immutable_cell (scm_t_bits car, scm_t_bits cdr)
{
  scm_c_issue_deprecation_warning
    ("scm_immutable_cell is deprecated.  Use scm_cell instead.");

  return scm_cell (car, cdr);
}

SCM
scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
			   scm_t_bits ccr, scm_t_bits cdr)
{
  scm_c_issue_deprecation_warning
    ("scm_immutable_double_cell is deprecated.  Use scm_double_cell instead.");

  return scm_double_cell (car, cbr, ccr, cdr);
}


\f

SCM_GLOBAL_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
void
scm_memory_error (const char *subr)
{
  scm_c_issue_deprecation_warning
    ("scm_memory_error is deprecated.  Use scm_report_out_of_memory to raise "
     "an exception, or abort() to cause the program to exit.");

  fprintf (stderr, "FATAL: memory error in %s\n", subr);
  abort ();
}


\f

SCM scm_no_applicable_method = SCM_BOOL_F;

void
scm_init_deprecated_goops (void)
{
  scm_no_applicable_method =
    scm_variable_ref (scm_c_lookup ("no-applicable-method"));
}

#define BUFFSIZE 32		/* big enough for most uses */
#define scm_si_specializers	 1  /* offset of spec. slot in a <method> */
#define SPEC_OF(x)  SCM_SLOT (x, scm_si_specializers)

static SCM
scm_i_vector2list (SCM l, long len)
{
  long j;
  SCM z = scm_c_make_vector (len, SCM_UNDEFINED);

  for (j = 0; j < len; j++, l = SCM_CDR (l)) {
    SCM_SIMPLE_VECTOR_SET (z, j, SCM_CAR (l));
  }
  return z;
}

static int
applicablep (SCM actual, SCM formal)
{
  /* We already know that the cpl is well formed. */
  return scm_is_true (scm_c_memq (formal, SCM_SLOT (actual, scm_si_cpl)));
}

static int
more_specificp (SCM m1, SCM m2, SCM const *targs)
{
  register SCM s1, s2;
  register long i;
  /*
   * Note:
   *   m1 and m2 can have != length (i.e. one can be one element longer than the
   * other when we have a dotted parameter list). For instance, with the call
   *   (M 1)
   * with
   *   (define-method M (a . l) ....)
   *   (define-method M (a) ....)
   *
   * we consider that the second method is more specific.
   *
   * BTW, targs is an array of types. We don't need it's size since
   * we already know that m1 and m2 are applicable (no risk to go past
   * the end of this array).
   *
   */
  for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) {
    if (scm_is_null(s1)) return 1;
    if (scm_is_null(s2)) return 0;
    if (!scm_is_eq (SCM_CAR(s1), SCM_CAR(s2))) {
      register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);

      for (l = SCM_SLOT (targs[i], scm_si_cpl);   ; l = SCM_CDR(l)) {
	if (scm_is_eq (cs1, SCM_CAR (l)))
	  return 1;
	if (scm_is_eq (cs2, SCM_CAR (l)))
	  return 0;
      }
      return 0;/* should not occur! */
    }
  }
  return 0; /* should not occur! */
}

static SCM
sort_applicable_methods (SCM method_list, long size, SCM const *targs)
{
  long i, j, incr;
  SCM *v, vector = SCM_EOL;
  SCM buffer[BUFFSIZE];
  SCM save = method_list;
  scm_t_array_handle handle;

  /* For reasonably sized method_lists we can try to avoid all the
   * consing and reorder the list in place...
   * This idea is due to David McClain <Dave_McClain@msn.com>
   */
  if (size <= BUFFSIZE)
    {
      for (i = 0;  i < size; i++)
	{
	  buffer[i]   = SCM_CAR (method_list);
	  method_list = SCM_CDR (method_list);
	}
      v = buffer;
    }
  else
    {
      /* Too many elements in method_list to keep everything locally */
      vector = scm_i_vector2list (save, size);
      v = scm_vector_writable_elements (vector, &handle, NULL, NULL);
    }

  /* Use a simple shell sort since it is generally faster than qsort on
   * small vectors (which is probably mostly the case when we have to
   * sort a list of applicable methods).
   */
  for (incr = size / 2; incr; incr /= 2)
    {
      for (i = incr; i < size; i++)
	{
	  for (j = i - incr; j >= 0; j -= incr)
	    {
	      if (more_specificp (v[j], v[j+incr], targs))
		break;
	      else
		{
		  SCM tmp = v[j + incr];
		  v[j + incr] = v[j];
		  v[j] = tmp;
		}
	    }
	}
    }

  if (size <= BUFFSIZE)
    {
      /* We did it in locally, so restore the original list (reordered) in-place */
      for (i = 0, method_list = save; i < size; i++, v++)
	{
	  SCM_SETCAR (method_list, *v);
	  method_list = SCM_CDR (method_list);
	}
      return save;
    }

  /* If we are here, that's that we did it the hard way... */
  scm_array_handle_release (&handle);
  return scm_vector_to_list (vector);
}

SCM
scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
{
  register long i;
  long count = 0;
  SCM l, fl, applicable = SCM_EOL;
  SCM save = args;
  SCM buffer[BUFFSIZE];
  SCM const *types;
  SCM *p;
  SCM tmp = SCM_EOL;
  scm_t_array_handle handle;

  scm_c_issue_deprecation_warning
    ("scm_compute_applicable_methods is deprecated.  Use "
     "`compute-applicable-methods' from Scheme instead.");

  /* Build the list of arguments types */
  if (len >= BUFFSIZE) 
    {
      tmp = scm_c_make_vector (len, SCM_UNDEFINED);
      types = p = scm_vector_writable_elements (tmp, &handle, NULL, NULL);

    /*
      note that we don't have to work to reset the generation
      count. TMP is a new vector anyway, and it is found
      conservatively.
    */
    }
  else
    types = p = buffer;

  for (  ; !scm_is_null (args); args = SCM_CDR (args))
    *p++ = scm_class_of (SCM_CAR (args));
  
  /* Build a list of all applicable methods */
  for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
    {
      fl = SPEC_OF (SCM_CAR (l));
      for (i = 0; ; i++, fl = SCM_CDR (fl))
	{
	  if (SCM_INSTANCEP (fl)
	      /* We have a dotted argument list */
	      || (i >= len && scm_is_null (fl)))
	    {	/* both list exhausted */
	      applicable = scm_cons (SCM_CAR (l), applicable);
	      count     += 1;
	      break;
	    }
	  if (i >= len
	      || scm_is_null (fl)
	      || !applicablep (types[i], SCM_CAR (fl)))
	    break;
	}
    }

  if (len >= BUFFSIZE)
      scm_array_handle_release (&handle);

  if (count == 0)
    {
      if (find_method_p)
	return SCM_BOOL_F;
      scm_call_2 (scm_no_applicable_method, gf, save);
      /* if we are here, it's because no-applicable-method hasn't signaled an error */
      return SCM_BOOL_F;
    }

  return (count == 1
	  ? applicable
	  : sort_applicable_methods (applicable, count, types));
}

SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");

SCM
scm_find_method (SCM l)
#define FUNC_NAME "find-method"
{
  SCM gf;
  long len = scm_ilength (l);

  if (len == 0)
    SCM_WRONG_NUM_ARGS ();

  scm_c_issue_deprecation_warning
    ("scm_find_method is deprecated.  Use `compute-applicable-methods' "
     "from Scheme instead.");

  gf = SCM_CAR(l); l = SCM_CDR(l);
  SCM_VALIDATE_GENERIC (1, gf);
  if (scm_is_null (SCM_SLOT (gf, scm_si_methods)))
    SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf));

  return scm_compute_applicable_methods (gf, l, len - 1, 1);
}
#undef FUNC_NAME

SCM
scm_basic_make_class (SCM meta, SCM name, SCM dsupers, SCM dslots)
{
  scm_c_issue_deprecation_warning
    ("scm_basic_make_class is deprecated.  Use `define-class' in Scheme,"
     "or use `(make META #:name NAME #:dsupers DSUPERS #:slots DSLOTS)' "
     "in Scheme.");

  return scm_make_standard_class (meta, name, dsupers, dslots);
}


\f

void
scm_i_init_deprecated ()
{
#include "libguile/deprecated.x"
}

#endif
Commit	Line	Data
19e2247d MV	1	/* This file contains definitions for deprecated features. When you
	2	deprecate something, move it here when that is feasible.
	3	*/
	4
28b818d3	5	/* Copyright (C) 2003, 2004, 2006, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015 Free Software Foundation, Inc.
19e2247d	6	*
73be1d9e	7	* This library is free software; you can redistribute it and/or
53befeb7 NJ	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.
19e2247d	11	*
53befeb7 NJ	12	* This library is distributed in the hope that it will be useful, but
53befeb7 NJ	13	* WITHOUT ANY WARRANTY; without even the implied warranty of
73be1d9e MV	14	* MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
73be1d9e MV	15	* Lesser General Public License for more details.
19e2247d	16	*
73be1d9e MV	17	* You should have received a copy of the GNU Lesser General Public
73be1d9e MV	18	* License along with this library; if not, write to the Free Software
53befeb7 NJ	19	* Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
53befeb7 NJ	20	* 02110-1301 USA
73be1d9e	21	*/
19e2247d	22
dbb605f5 LC	23	#ifdef HAVE_CONFIG_H
	24	# include <config.h>
	25	#endif
	26
0eb934f1 LC	27	#define SCM_BUILDING_DEPRECATED_CODE
0eb934f1 LC	28
19e2247d	29	#include "libguile/_scm.h"
55d30fac	30	#include "libguile/deprecation.h"
3452e666	31
19e2247d MV	32	#if (SCM_ENABLE_DEPRECATED == 1)
19e2247d MV	33
f3c6a02c AW	34	\f
f3c6a02c AW	35
b2feee6b AW	36	SCM
	37	scm_internal_dynamic_wind (scm_t_guard before,
	38	scm_t_inner inner,
	39	scm_t_guard after,
	40	void *inner_data,
	41	void *guard_data)
	42	{
	43	SCM ans;
	44
	45	scm_c_issue_deprecation_warning
	46	("`scm_internal_dynamic_wind' is deprecated. "
	47	"Use the `scm_dynwind_begin' / `scm_dynwind_end' API instead.");
	48
	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);
	53	scm_dynwind_end ();
	54	return ans;
	55	}
	56
	57	\f
	58
65619ebe AW	59	SCM
	60	scm_immutable_cell (scm_t_bits car, scm_t_bits cdr)
	61	{
	62	scm_c_issue_deprecation_warning
	63	("scm_immutable_cell is deprecated. Use scm_cell instead.");
	64
	65	return scm_cell (car, cdr);
	66	}
	67
	68	SCM
	69	scm_immutable_double_cell (scm_t_bits car, scm_t_bits cbr,
	70	scm_t_bits ccr, scm_t_bits cdr)
	71	{
	72	scm_c_issue_deprecation_warning
	73	("scm_immutable_double_cell is deprecated. Use scm_double_cell instead.");
	74
	75	return scm_double_cell (car, cbr, ccr, cdr);
	76	}
	77
	78
	79	\f
	80
c2247b78 AW	81	SCM_GLOBAL_SYMBOL (scm_memory_alloc_key, "memory-allocation-error");
	82	void
	83	scm_memory_error (const char *subr)
	84	{
	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.");
	88
	89	fprintf (stderr, "FATAL: memory error in %s\n", subr);
	90	abort ();
	91	}
	92
	93
	94	\f
	95
623559f3 AW	96	SCM scm_no_applicable_method = SCM_BOOL_F;
	97
	98	void
	99	scm_init_deprecated_goops (void)
	100	{
	101	scm_no_applicable_method =
	102	scm_variable_ref (scm_c_lookup ("no-applicable-method"));
	103	}
	104
e4aa440a	105	#define BUFFSIZE 32 /* big enough for most uses */
9e2cd55e	106	#define scm_si_specializers 1 /* offset of spec. slot in a <method> */
e4aa440a AW	107	#define SPEC_OF(x) SCM_SLOT (x, scm_si_specializers)
	108
	109	static SCM
	110	scm_i_vector2list (SCM l, long len)
	111	{
	112	long j;
	113	SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
	114
	115	for (j = 0; j < len; j++, l = SCM_CDR (l)) {
	116	SCM_SIMPLE_VECTOR_SET (z, j, SCM_CAR (l));
	117	}
	118	return z;
	119	}
	120
	121	static int
	122	applicablep (SCM actual, SCM formal)
	123	{
	124	/* We already know that the cpl is well formed. */
	125	return scm_is_true (scm_c_memq (formal, SCM_SLOT (actual, scm_si_cpl)));
	126	}
	127
	128	static int
	129	more_specificp (SCM m1, SCM m2, SCM const *targs)
	130	{
	131	register SCM s1, s2;
	132	register long i;
	133	/*
	134	* Note:
	135	* m1 and m2 can have != length (i.e. one can be one element longer than the
	136	* other when we have a dotted parameter list). For instance, with the call
	137	* (M 1)
	138	* with
	139	* (define-method M (a . l) ....)
	140	* (define-method M (a) ....)
	141	*
	142	* we consider that the second method is more specific.
	143	*
	144	* BTW, targs is an array of types. We don't need it's size since
	145	* we already know that m1 and m2 are applicable (no risk to go past
	146	* the end of this array).
	147	*
	148	*/
	149	for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) {
	150	if (scm_is_null(s1)) return 1;
	151	if (scm_is_null(s2)) return 0;
	152	if (!scm_is_eq (SCM_CAR(s1), SCM_CAR(s2))) {
	153	register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
	154
	155	for (l = SCM_SLOT (targs[i], scm_si_cpl); ; l = SCM_CDR(l)) {
	156	if (scm_is_eq (cs1, SCM_CAR (l)))
	157	return 1;
	158	if (scm_is_eq (cs2, SCM_CAR (l)))
	159	return 0;
	160	}
	161	return 0;/* should not occur! */
	162	}
	163	}
	164	return 0; /* should not occur! */
	165	}
	166
	167	static SCM
	168	sort_applicable_methods (SCM method_list, long size, SCM const *targs)
	169	{
	170	long i, j, incr;
171	SCM *v, vector = SCM_EOL;
172	SCM buffer[BUFFSIZE];
173	SCM save = method_list;
174	scm_t_array_handle handle;
175
176	/* For reasonably sized method_lists we can try to avoid all the
177	* consing and reorder the list in place...
178	* This idea is due to David McClain <Dave_McClain@msn.com>
179	*/
180	if (size <= BUFFSIZE)
181	{
182	for (i = 0; i < size; i++)
183	{
184	buffer[i] = SCM_CAR (method_list);
185	method_list = SCM_CDR (method_list);
186	}
187	v = buffer;
188	}
189	else
190	{
191	/* Too many elements in method_list to keep everything locally */
192	vector = scm_i_vector2list (save, size);
193	v = scm_vector_writable_elements (vector, &handle, NULL, NULL);
194	}
195
196	/* Use a simple shell sort since it is generally faster than qsort on
197	* small vectors (which is probably mostly the case when we have to
198	* sort a list of applicable methods).
199	*/
200	for (incr = size / 2; incr; incr /= 2)
201	{
202	for (i = incr; i < size; i++)
203	{
204	for (j = i - incr; j >= 0; j -= incr)
205	{
206	if (more_specificp (v[j], v[j+incr], targs))
207	break;
208	else
209	{
210	SCM tmp = v[j + incr];
211	v[j + incr] = v[j];
212	v[j] = tmp;
213	}
214	}
215	}
216	}
217
218	if (size <= BUFFSIZE)
219	{
220	/* We did it in locally, so restore the original list (reordered) in-place */
221	for (i = 0, method_list = save; i < size; i++, v++)
222	{
223	SCM_SETCAR (method_list, *v);
224	method_list = SCM_CDR (method_list);
225	}
226	return save;
227	}
228
229	/* If we are here, that's that we did it the hard way... */
230	scm_array_handle_release (&handle);
231	return scm_vector_to_list (vector);
232	}
233
234	SCM
235	scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
236	{
237	register long i;
238	long count = 0;
239	SCM l, fl, applicable = SCM_EOL;
240	SCM save = args;
241	SCM buffer[BUFFSIZE];
242	SCM const *types;
243	SCM *p;
244	SCM tmp = SCM_EOL;
245	scm_t_array_handle handle;
246
247	scm_c_issue_deprecation_warning
248	("scm_compute_applicable_methods is deprecated. Use "
249	"`compute-applicable-methods' from Scheme instead.");
250
251	/* Build the list of arguments types */
252	if (len >= BUFFSIZE)
253	{
254	tmp = scm_c_make_vector (len, SCM_UNDEFINED);
255	types = p = scm_vector_writable_elements (tmp, &handle, NULL, NULL);
256
257	/*
258	note that we don't have to work to reset the generation
259	count. TMP is a new vector anyway, and it is found
260	conservatively.
261	*/
262	}
263	else
264	types = p = buffer;
265
266	for ( ; !scm_is_null (args); args = SCM_CDR (args))
267	*p++ = scm_class_of (SCM_CAR (args));
268
269	/* Build a list of all applicable methods */
270	for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
271	{
272	fl = SPEC_OF (SCM_CAR (l));
273	for (i = 0; ; i++, fl = SCM_CDR (fl))
274	{
275	if (SCM_INSTANCEP (fl)
276	/* We have a dotted argument list */
277	\|\| (i >= len && scm_is_null (fl)))
278	{ /* both list exhausted */
279	applicable = scm_cons (SCM_CAR (l), applicable);
280	count += 1;
281	break;
282	}
283	if (i >= len
284	\|\| scm_is_null (fl)
285	\|\| !applicablep (types[i], SCM_CAR (fl)))
286	break;
287	}
288	}
289
290	if (len >= BUFFSIZE)
291	scm_array_handle_release (&handle);
292
293	if (count == 0)
294	{
295	if (find_method_p)
296	return SCM_BOOL_F;
297	scm_call_2 (scm_no_applicable_method, gf, save);
298	/* if we are here, it's because no-applicable-method hasn't signaled an error */
299	return SCM_BOOL_F;
300	}
301
302	return (count == 1
303	? applicable
304	: sort_applicable_methods (applicable, count, types));
305	}
306
307	SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
308
309	SCM
310	scm_find_method (SCM l)
311	#define FUNC_NAME "find-method"
312	{
313	SCM gf;
314	long len = scm_ilength (l);
315
316	if (len == 0)
317	SCM_WRONG_NUM_ARGS ();
318
319	scm_c_issue_deprecation_warning
320	("scm_find_method is deprecated. Use `compute-applicable-methods' "
321	"from Scheme instead.");
322
323	gf = SCM_CAR(l); l = SCM_CDR(l);
324	SCM_VALIDATE_GENERIC (1, gf);
325	if (scm_is_null (SCM_SLOT (gf, scm_si_methods)))
326	SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf));
327
328	return scm_compute_applicable_methods (gf, l, len - 1, 1);
329	}
330	#undef FUNC_NAME
331
28b818d3 AW	332	SCM
	333	scm_basic_make_class (SCM meta, SCM name, SCM dsupers, SCM dslots)
	334	{
	335	scm_c_issue_deprecation_warning
	336	("scm_basic_make_class is deprecated. Use `define-class' in Scheme,"
	337	"or use `(make META #:name NAME #:dsupers DSUPERS #:slots DSLOTS)' "
	338	"in Scheme.");
	339
	340	return scm_make_standard_class (meta, name, dsupers, dslots);
	341	}
	342
e4aa440a AW	343
	344	\f
	345
19e2247d MV	346	void
	347	scm_i_init_deprecated ()
	348	{
	349	#include "libguile/deprecated.x"
	350	}
	351
	352	#endif