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 SCM scm_class_boolean, scm_class_char, scm_class_pair;
  99 SCM scm_class_procedure, scm_class_string, scm_class_symbol;
 100 SCM scm_class_primitive_generic;
 101 SCM scm_class_vector, scm_class_null;
 102 SCM scm_class_integer, scm_class_real, scm_class_complex, scm_class_fraction;
 103 SCM scm_class_unknown;
 104 SCM scm_class_top, scm_class_object, scm_class_class;
 105 SCM scm_class_applicable;
 106 SCM scm_class_applicable_struct, scm_class_applicable_struct_with_setter;
 107 SCM scm_class_generic, scm_class_generic_with_setter;
 108 SCM scm_class_accessor;
 109 SCM scm_class_extended_generic, scm_class_extended_generic_with_setter;
 110 SCM scm_class_extended_accessor;
 111 SCM scm_class_method;
 112 SCM scm_class_accessor_method;
 113 SCM scm_class_procedure_class;
 114 SCM scm_class_applicable_struct_class;
 115 SCM scm_class_number, scm_class_list;
 116 SCM scm_class_keyword;
 117 SCM scm_class_port, scm_class_input_output_port;
 118 SCM scm_class_input_port, scm_class_output_port;
 119 SCM scm_class_foreign_slot;
 120 SCM scm_class_self, scm_class_protected;
 121 SCM scm_class_hidden, scm_class_opaque, scm_class_read_only;
 122 SCM scm_class_protected_hidden, scm_class_protected_opaque, scm_class_protected_read_only;
 123 SCM scm_class_scm;
 124 SCM scm_class_int, scm_class_float, scm_class_double;
 125
 126 SCM *scm_port_class, *scm_smob_class;
 127
 128 void
 129 scm_init_deprecated_goops (void)
 130 {
 131   scm_no_applicable_method =
 132     scm_variable_ref (scm_c_lookup ("no-applicable-method"));
 133
 134   scm_class_class = scm_variable_ref (scm_c_lookup ("<class>"));
 135   scm_class_top = scm_variable_ref (scm_c_lookup ("<top>"));
 136   scm_class_object = scm_variable_ref (scm_c_lookup ("<object>"));
 137
 138   scm_class_foreign_slot = scm_variable_ref (scm_c_lookup ("<foreign-slot>"));
 139   scm_class_protected = scm_variable_ref (scm_c_lookup ("<protected-slot>"));
 140   scm_class_hidden = scm_variable_ref (scm_c_lookup ("<hidden-slot>"));
 141   scm_class_opaque = scm_variable_ref (scm_c_lookup ("<opaque-slot>"));
 142   scm_class_read_only = scm_variable_ref (scm_c_lookup ("<read-only-slot>"));
 143   scm_class_self = scm_variable_ref (scm_c_lookup ("<self-slot>"));
 144   scm_class_protected_opaque = scm_variable_ref (scm_c_lookup ("<protected-opaque-slot>"));
 145   scm_class_protected_hidden = scm_variable_ref (scm_c_lookup ("<protected-hidden-slot>"));
 146   scm_class_protected_read_only = scm_variable_ref (scm_c_lookup ("<protected-read-only-slot>"));
 147   scm_class_scm = scm_variable_ref (scm_c_lookup ("<scm-slot>"));
 148   scm_class_int = scm_variable_ref (scm_c_lookup ("<int-slot>"));
 149   scm_class_float = scm_variable_ref (scm_c_lookup ("<float-slot>"));
 150   scm_class_double = scm_variable_ref (scm_c_lookup ("<double-slot>"));
 151
 152   /* scm_class_generic functions classes */
 153   scm_class_procedure_class = scm_variable_ref (scm_c_lookup ("<procedure-class>"));
 154   scm_class_applicable_struct_class = scm_variable_ref (scm_c_lookup ("<applicable-struct-class>"));
 155
 156   scm_class_method = scm_variable_ref (scm_c_lookup ("<method>"));
 157   scm_class_accessor_method = scm_variable_ref (scm_c_lookup ("<accessor-method>"));
 158   scm_class_applicable = scm_variable_ref (scm_c_lookup ("<applicable>"));
 159   scm_class_applicable_struct = scm_variable_ref (scm_c_lookup ("<applicable-struct>"));
 160   scm_class_applicable_struct_with_setter = scm_variable_ref (scm_c_lookup ("<applicable-struct-with-setter>"));
 161   scm_class_generic = scm_variable_ref (scm_c_lookup ("<generic>"));
 162   scm_class_extended_generic = scm_variable_ref (scm_c_lookup ("<extended-generic>"));
 163   scm_class_generic_with_setter = scm_variable_ref (scm_c_lookup ("<generic-with-setter>"));
 164   scm_class_accessor = scm_variable_ref (scm_c_lookup ("<accessor>"));
 165   scm_class_extended_generic_with_setter = scm_variable_ref (scm_c_lookup ("<extended-generic-with-setter>"));
 166   scm_class_extended_accessor = scm_variable_ref (scm_c_lookup ("<extended-accessor>"));
 167
 168   /* Primitive types classes */
 169   scm_class_boolean = scm_variable_ref (scm_c_lookup ("<boolean>"));
 170   scm_class_char = scm_variable_ref (scm_c_lookup ("<char>"));
 171   scm_class_list = scm_variable_ref (scm_c_lookup ("<list>"));
 172   scm_class_pair = scm_variable_ref (scm_c_lookup ("<pair>"));
 173   scm_class_null = scm_variable_ref (scm_c_lookup ("<null>"));
 174   scm_class_string = scm_variable_ref (scm_c_lookup ("<string>"));
 175   scm_class_symbol = scm_variable_ref (scm_c_lookup ("<symbol>"));
 176   scm_class_vector = scm_variable_ref (scm_c_lookup ("<vector>"));
 177   scm_class_number = scm_variable_ref (scm_c_lookup ("<number>"));
 178   scm_class_complex = scm_variable_ref (scm_c_lookup ("<complex>"));
 179   scm_class_real = scm_variable_ref (scm_c_lookup ("<real>"));
 180   scm_class_integer = scm_variable_ref (scm_c_lookup ("<integer>"));
 181   scm_class_fraction = scm_variable_ref (scm_c_lookup ("<fraction>"));
 182   scm_class_keyword = scm_variable_ref (scm_c_lookup ("<keyword>"));
 183   scm_class_unknown = scm_variable_ref (scm_c_lookup ("<unknown>"));
 184   scm_class_procedure = scm_variable_ref (scm_c_lookup ("<procedure>"));
 185   scm_class_primitive_generic = scm_variable_ref (scm_c_lookup ("<primitive-generic>"));
 186   scm_class_port = scm_variable_ref (scm_c_lookup ("<port>"));
 187   scm_class_input_port = scm_variable_ref (scm_c_lookup ("<input-port>"));
 188   scm_class_output_port = scm_variable_ref (scm_c_lookup ("<output-port>"));
 189   scm_class_input_output_port = scm_variable_ref (scm_c_lookup ("<input-output-port>"));
 190
 191   scm_port_class = scm_i_port_class;
 192   scm_smob_class = scm_i_smob_class;
 193 }
 194
 195 #define BUFFSIZE 32             /* big enough for most uses */
 196 #define SPEC_OF(x) \
 197   (scm_slot_ref (x, scm_slot_ref (x, scm_from_latin1_symbol ("specializers"))))
 198 #define CPL_OF(x) \
 199   (scm_slot_ref (x, scm_slot_ref (x, scm_from_latin1_symbol ("cpl"))))
 200
 201 static SCM
 202 scm_i_vector2list (SCM l, long len)
 203 {
 204   long j;
 205   SCM z = scm_c_make_vector (len, SCM_UNDEFINED);
 206
 207   for (j = 0; j < len; j++, l = SCM_CDR (l)) {
 208     SCM_SIMPLE_VECTOR_SET (z, j, SCM_CAR (l));
 209   }
 210   return z;
 211 }
 212
 213 static int
 214 applicablep (SCM actual, SCM formal)
 215 {
 216   /* We already know that the cpl is well formed. */
 217   return scm_is_true (scm_c_memq (formal, CPL_OF (actual)));
 218 }
 219
 220 static int
 221 more_specificp (SCM m1, SCM m2, SCM const *targs)
 222 {
 223   register SCM s1, s2;
 224   register long i;
 225   /*
 226    * Note:
 227    *   m1 and m2 can have != length (i.e. one can be one element longer than the
 228    * other when we have a dotted parameter list). For instance, with the call
 229    *   (M 1)
 230    * with
 231    *   (define-method M (a . l) ....)
 232    *   (define-method M (a) ....)
 233    *
 234    * we consider that the second method is more specific.
 235    *
 236    * BTW, targs is an array of types. We don't need it's size since
 237    * we already know that m1 and m2 are applicable (no risk to go past
 238    * the end of this array).
 239    *
 240    */
 241   for (i=0, s1=SPEC_OF(m1), s2=SPEC_OF(m2); ; i++, s1=SCM_CDR(s1), s2=SCM_CDR(s2)) {
 242     if (scm_is_null(s1)) return 1;
 243     if (scm_is_null(s2)) return 0;
 244     if (!scm_is_eq (SCM_CAR(s1), SCM_CAR(s2))) {
 245       register SCM l, cs1 = SCM_CAR(s1), cs2 = SCM_CAR(s2);
 246
 247       for (l = CPL_OF (targs[i]);   ; l = SCM_CDR(l)) {
 248         if (scm_is_eq (cs1, SCM_CAR (l)))
 249           return 1;
 250         if (scm_is_eq (cs2, SCM_CAR (l)))
 251           return 0;
 252       }
 253       return 0;/* should not occur! */
 254     }
 255   }
 256   return 0; /* should not occur! */
 257 }
 258
 259 static SCM
 260 sort_applicable_methods (SCM method_list, long size, SCM const *targs)
 261 {
 262   long i, j, incr;
 263   SCM *v, vector = SCM_EOL;
 264   SCM buffer[BUFFSIZE];
 265   SCM save = method_list;
 266   scm_t_array_handle handle;
 267
 268   /* For reasonably sized method_lists we can try to avoid all the
 269    * consing and reorder the list in place...
 270    * This idea is due to David McClain <Dave_McClain@msn.com>
 271    */
 272   if (size <= BUFFSIZE)
 273     {
 274       for (i = 0;  i < size; i++)
 275         {
 276           buffer[i]   = SCM_CAR (method_list);
 277           method_list = SCM_CDR (method_list);
 278         }
 279       v = buffer;
 280     }
 281   else
 282     {
 283       /* Too many elements in method_list to keep everything locally */
 284       vector = scm_i_vector2list (save, size);
 285       v = scm_vector_writable_elements (vector, &handle, NULL, NULL);
 286     }
 287
 288   /* Use a simple shell sort since it is generally faster than qsort on
 289    * small vectors (which is probably mostly the case when we have to
 290    * sort a list of applicable methods).
 291    */
 292   for (incr = size / 2; incr; incr /= 2)
 293     {
 294       for (i = incr; i < size; i++)
 295         {
 296           for (j = i - incr; j >= 0; j -= incr)
 297             {
 298               if (more_specificp (v[j], v[j+incr], targs))
 299                 break;
 300               else
 301                 {
 302                   SCM tmp = v[j + incr];
 303                   v[j + incr] = v[j];
 304                   v[j] = tmp;
 305                 }
 306             }
 307         }
 308     }
 309
 310   if (size <= BUFFSIZE)
 311     {
 312       /* We did it in locally, so restore the original list (reordered) in-place */
 313       for (i = 0, method_list = save; i < size; i++, v++)
 314         {
 315           SCM_SETCAR (method_list, *v);
 316           method_list = SCM_CDR (method_list);
 317         }
 318       return save;
 319     }
 320
 321   /* If we are here, that's that we did it the hard way... */
 322   scm_array_handle_release (&handle);
 323   return scm_vector_to_list (vector);
 324 }
 325
 326 SCM
 327 scm_compute_applicable_methods (SCM gf, SCM args, long len, int find_method_p)
 328 {
 329   register long i;
 330   long count = 0;
 331   SCM l, fl, applicable = SCM_EOL;
 332   SCM save = args;
 333   SCM buffer[BUFFSIZE];
 334   SCM const *types;
 335   SCM *p;
 336   SCM tmp = SCM_EOL;
 337   scm_t_array_handle handle;
 338
 339   scm_c_issue_deprecation_warning
 340     ("scm_compute_applicable_methods is deprecated.  Use "
 341      "`compute-applicable-methods' from Scheme instead.");
 342
 343   /* Build the list of arguments types */
 344   if (len >= BUFFSIZE)
 345     {
 346       tmp = scm_c_make_vector (len, SCM_UNDEFINED);
 347       types = p = scm_vector_writable_elements (tmp, &handle, NULL, NULL);
 348
 349     /*
 350       note that we don't have to work to reset the generation
 351       count. TMP is a new vector anyway, and it is found
 352       conservatively.
 353     */
 354     }
 355   else
 356     types = p = buffer;
 357
 358   for (  ; !scm_is_null (args); args = SCM_CDR (args))
 359     *p++ = scm_class_of (SCM_CAR (args));
 360
 361   /* Build a list of all applicable methods */
 362   for (l = scm_generic_function_methods (gf); !scm_is_null (l); l = SCM_CDR (l))
 363     {
 364       fl = SPEC_OF (SCM_CAR (l));
 365       for (i = 0; ; i++, fl = SCM_CDR (fl))
 366         {
 367           if (SCM_INSTANCEP (fl)
 368               /* We have a dotted argument list */
 369               || (i >= len && scm_is_null (fl)))
 370             {   /* both list exhausted */
 371               applicable = scm_cons (SCM_CAR (l), applicable);
 372               count     += 1;
 373               break;
 374             }
 375           if (i >= len
 376               || scm_is_null (fl)
 377               || !applicablep (types[i], SCM_CAR (fl)))
 378             break;
 379         }
 380     }
 381
 382   if (len >= BUFFSIZE)
 383       scm_array_handle_release (&handle);
 384
 385   if (count == 0)
 386     {
 387       if (find_method_p)
 388         return SCM_BOOL_F;
 389       scm_call_2 (scm_no_applicable_method, gf, save);
 390       /* if we are here, it's because no-applicable-method hasn't signaled an error */
 391       return SCM_BOOL_F;
 392     }
 393
 394   return (count == 1
 395           ? applicable
 396           : sort_applicable_methods (applicable, count, types));
 397 }
 398
 399 SCM_SYMBOL (sym_compute_applicable_methods, "compute-applicable-methods");
 400
 401 SCM
 402 scm_find_method (SCM l)
 403 #define FUNC_NAME "find-method"
 404 {
 405   SCM gf;
 406   long len = scm_ilength (l);
 407
 408   if (len == 0)
 409     SCM_WRONG_NUM_ARGS ();
 410
 411   scm_c_issue_deprecation_warning
 412     ("scm_find_method is deprecated.  Use `compute-applicable-methods' "
 413      "from Scheme instead.");
 414
 415   gf = SCM_CAR(l); l = SCM_CDR(l);
 416   SCM_VALIDATE_GENERIC (1, gf);
 417   if (scm_is_null (scm_slot_ref (gf, scm_from_latin1_symbol ("methods"))))
 418     SCM_MISC_ERROR ("no methods for generic ~S", scm_list_1 (gf));
 419
 420   return scm_compute_applicable_methods (gf, l, len - 1, 1);
 421 }
 422 #undef FUNC_NAME
 423
 424 SCM
 425 scm_basic_make_class (SCM meta, SCM name, SCM dsupers, SCM dslots)
 426 {
 427   scm_c_issue_deprecation_warning
 428     ("scm_basic_make_class is deprecated.  Use `define-class' in Scheme,"
 429      "or use `(make META #:name NAME #:dsupers DSUPERS #:slots DSLOTS)' "
 430      "in Scheme.");
 431
 432   return scm_make_standard_class (meta, name, dsupers, dslots);
 433 }
 434
 435
 436 \f
 437
 438 void
 439 scm_i_init_deprecated ()
 440 {
 441 #include "libguile/deprecated.x"
 442 }
 443
 444 #endif