libguile/deprecated.c

   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 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 "libguile/_scm.h"
  30 #include "libguile/deprecation.h"
  31
  32 #if (SCM_ENABLE_DEPRECATED == 1)
  33
  34 \f
  35
  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
  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
  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
  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
 105 #define BUFFSIZE 32             /* big enough for most uses */
 106 #define SPEC_OF(x)  SCM_SLOT (x, scm_si_specializers)
 107
 108 static SCM
 109 scm_i_vector2list (SCM l, long len)
 110 {
 111   long j;
 112   SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
 113
 114   for (j = 0; j < len; j++, l = SCM_CDR (l)) {
 115     SCM_SIMPLE_VECTOR_SET (z, j, SCM_CAR (l));
 116   }
 117   return z;
 118 }
 119
 120 static int
 121 applicablep (SCM actual, SCM formal)
 122 {
 123   /* We already know that the cpl is well formed. */
 124   return scm_is_true (scm_c_memq (formal, SCM_SLOT (actual, scm_si_cpl)));
 125 }
 126
 127 static int
 128 more_specificp (SCM m1, SCM m2, SCM const *targs)
 129 {
 130   register SCM s1, s2;
 131   register long i;
 132   /*
 133    * Note:
 134    *   m1 and m2 can have != length (i.e. one can be one element longer than the
 135    * other when we have a dotted parameter list). For instance, with the call
 136    *   (M 1)
 137    * with
 138    *   (define-method M (a . l) ....)
 139    *   (define-method M (a) ....)
 140    *
 141    * we consider that the second method is more specific.
 142    *
 143    * BTW, targs is an array of types. We don't need it's size since
 144    * we already know that m1 and m2 are applicable (no risk to go past
 145    * the end of this array).
 146    *
 147    */
 148   for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) {
 149     if (scm_is_null(s1)) return 1;
 150     if (scm_is_null(s2)) return 0;
 151     if (!scm_is_eq (SCM_CAR(s1), SCM_CAR(s2))) {
 152       register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
 153
 154       for (l = SCM_SLOT (targs[i], scm_si_cpl);   ; l = SCM_CDR(l)) {
 155         if (scm_is_eq (cs1, SCM_CAR (l)))
 156           return 1;
 157         if (scm_is_eq (cs2, SCM_CAR (l)))
 158           return 0;
 159       }
 160       return 0;/* should not occur! */
 161     }
 162   }
 163   return 0; /* should not occur! */
 164 }
 165
 166 static SCM
 167 sort_applicable_methods (SCM method_list, long size, SCM const *targs)
 168 {
 169   long i, j, incr;
 170   SCM *v, vector = SCM_EOL;
 171   SCM buffer[BUFFSIZE];
 172   SCM save = method_list;
 173   scm_t_array_handle handle;
 174
 175   /* For reasonably sized method_lists we can try to avoid all the
 176    * consing and reorder the list in place...
 177    * This idea is due to David McClain <Dave_McClain@msn.com>
 178    */
 179   if (size <= BUFFSIZE)
 180     {
 181       for (i = 0;  i < size; i++)
 182         {
 183           buffer[i]   = SCM_CAR (method_list);
 184           method_list = SCM_CDR (method_list);
 185         }
 186       v = buffer;
 187     }
 188   else
 189     {
 190       /* Too many elements in method_list to keep everything locally */
 191       vector = scm_i_vector2list (save, size);
 192       v = scm_vector_writable_elements (vector, &handle, NULL, NULL);
 193     }
 194
 195   /* Use a simple shell sort since it is generally faster than qsort on
 196    * small vectors (which is probably mostly the case when we have to
 197    * sort a list of applicable methods).
 198    */
 199   for (incr = size / 2; incr; incr /= 2)
 200     {
 201       for (i = incr; i < size; i++)
 202         {
 203           for (j = i - incr; j >= 0; j -= incr)
 204             {
 205               if (more_specificp (v[j], v[j+incr], targs))
 206                 break;
 207               else
 208                 {
 209                   SCM tmp = v[j + incr];
 210                   v[j + incr] = v[j];
 211                   v[j] = tmp;
 212                 }
 213             }
 214         }
 215     }
 216
 217   if (size <= BUFFSIZE)
 218     {
 219       /* We did it in locally, so restore the original list (reordered) in-place */
 220       for (i = 0, method_list = save; i < size; i++, v++)
 221         {
 222           SCM_SETCAR (method_list, *v);
 223           method_list = SCM_CDR (method_list);
 224         }
 225       return save;
 226     }
 227
 228   /* If we are here, that's that we did it the hard way... */
 229   scm_array_handle_release (&handle);
 230   return scm_vector_to_list (vector);
 231 }
 232
 233 SCM
 234 scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
 235 {
 236   register long i;
 237   long count = 0;
 238   SCM l, fl, applicable = SCM_EOL;
 239   SCM save = args;
 240   SCM buffer[BUFFSIZE];
 241   SCM const *types;
 242   SCM *p;
 243   SCM tmp = SCM_EOL;
 244   scm_t_array_handle handle;
 245
 246   scm_c_issue_deprecation_warning
 247     ("scm_compute_applicable_methods is deprecated.  Use "
 248      "`compute-applicable-methods' from Scheme instead.");
 249
 250   /* Build the list of arguments types */
 251   if (len >= BUFFSIZE)
 252     {
 253       tmp = scm_c_make_vector (len, SCM_UNDEFINED);
 254       types = p = scm_vector_writable_elements (tmp, &handle, NULL, NULL);
 255
 256     /*
 257       note that we don't have to work to reset the generation
 258       count. TMP is a new vector anyway, and it is found
 259       conservatively.
 260     */
 261     }
 262   else
 263     types = p = buffer;
 264
 265   for (  ; !scm_is_null (args); args = SCM_CDR (args))
 266     *p++ = scm_class_of (SCM_CAR (args));
 267
 268   /* Build a list of all applicable methods */
 269   for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
 270     {
 271       fl = SPEC_OF (SCM_CAR (l));
 272       for (i = 0; ; i++, fl = SCM_CDR (fl))
 273         {
 274           if (SCM_INSTANCEP (fl)
 275               /* We have a dotted argument list */
 276               || (i >= len && scm_is_null (fl)))
 277             {   /* both list exhausted */
 278               applicable = scm_cons (SCM_CAR (l), applicable);
 279               count     += 1;
 280               break;
 281             }
 282           if (i >= len
 283               || scm_is_null (fl)
 284               || !applicablep (types[i], SCM_CAR (fl)))
 285             break;
 286         }
 287     }
 288
 289   if (len >= BUFFSIZE)
 290       scm_array_handle_release (&handle);
 291
 292   if (count == 0)
 293     {
 294       if (find_method_p)
 295         return SCM_BOOL_F;
 296       scm_call_2 (scm_no_applicable_method, gf, save);
 297       /* if we are here, it's because no-applicable-method hasn't signaled an error */
 298       return SCM_BOOL_F;
 299     }
 300
 301   return (count == 1
 302           ? applicable
 303           : sort_applicable_methods (applicable, count, types));
 304 }
 305
 306 SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
 307
 308 SCM
 309 scm_find_method (SCM l)
 310 #define FUNC_NAME "find-method"
 311 {
 312   SCM gf;
 313   long len = scm_ilength (l);
 314
 315   if (len == 0)
 316     SCM_WRONG_NUM_ARGS ();
 317
 318   scm_c_issue_deprecation_warning
 319     ("scm_find_method is deprecated.  Use `compute-applicable-methods' "
 320      "from Scheme instead.");
 321
 322   gf = SCM_CAR(l); l = SCM_CDR(l);
 323   SCM_VALIDATE_GENERIC (1, gf);
 324   if (scm_is_null (SCM_SLOT (gf, scm_si_methods)))
 325     SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf));
 326
 327   return scm_compute_applicable_methods (gf, l, len - 1, 1);
 328 }
 329 #undef FUNC_NAME
 330
 331 SCM
 332 scm_basic_make_class (SCM meta, SCM name, SCM dsupers, SCM dslots)
 333 {
 334   scm_c_issue_deprecation_warning
 335     ("scm_basic_make_class is deprecated.  Use `define-class' in Scheme,"
 336      "or use `(make META #:name NAME #:dsupers DSUPERS #:slots DSLOTS)' "
 337      "in Scheme.");
 338
 339   return scm_make_standard_class (meta, name, dsupers, dslots);
 340 }
 341
 342
 343 \f
 344
 345 void
 346 scm_i_init_deprecated ()
 347 {
 348 #include "libguile/deprecated.x"
 349 }
 350
 351 #endif