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 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
   9  * License as published by the Free Software Foundation; either
  10  * version 2.1 of the License, or (at your option) any later version.
  11  *
  12  * This library is distributed in the hope that it will be useful,
  13  * but 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., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
  20  */
  21
  22 #include "libguile/_scm.h"
  23 #include "libguile/deprecated.h"
  24 #include "libguile/deprecation.h"
  25 #include "libguile/snarf.h"
  26 #include "libguile/validate.h"
  27 #include "libguile/strings.h"
  28 #include "libguile/strop.h"
  29 #include "libguile/modules.h"
  30 #include "libguile/eval.h"
  31 #include "libguile/smob.h"
  32 #include "libguile/procprop.h"
  33 #include "libguile/vectors.h"
  34 #include "libguile/hashtab.h"
  35 #include "libguile/struct.h"
  36 #include "libguile/variable.h"
  37 #include "libguile/fluids.h"
  38 #include "libguile/ports.h"
  39 #include "libguile/eq.h"
  40 #include "libguile/read.h"
  41
  42 #include <stdio.h>
  43 #include <string.h>
  44
  45 #if (SCM_ENABLE_DEPRECATED == 1)
  46
  47 SCM_REGISTER_PROC(s_substring_move_left_x, "substring-move-left!", 5, 0, 0, scm_substring_move_x);
  48
  49 SCM_REGISTER_PROC(s_substring_move_right_x, "substring-move-right!", 5, 0, 0, scm_substring_move_x);
  50
  51 SCM
  52 scm_wta (SCM arg, const char *pos, const char *s_subr)
  53 {
  54   if (!s_subr || !*s_subr)
  55     s_subr = NULL;
  56   if ((~0x1fL) & (long) pos)
  57     {
  58       /* error string supplied.  */
  59       scm_misc_error (s_subr, pos, scm_list_1 (arg));
  60     }
  61   else
  62     {
  63       /* numerical error code.  */
  64       scm_t_bits error = (scm_t_bits) pos;
  65
  66       switch (error)
  67         {
  68         case SCM_ARGn:
  69           scm_wrong_type_arg (s_subr, 0, arg);
  70         case SCM_ARG1:
  71           scm_wrong_type_arg (s_subr, 1, arg);
  72         case SCM_ARG2:
  73           scm_wrong_type_arg (s_subr, 2, arg);
  74         case SCM_ARG3:
  75           scm_wrong_type_arg (s_subr, 3, arg);
  76         case SCM_ARG4:
  77           scm_wrong_type_arg (s_subr, 4, arg);
  78         case SCM_ARG5:
  79           scm_wrong_type_arg (s_subr, 5, arg);
  80         case SCM_ARG6:
  81           scm_wrong_type_arg (s_subr, 6, arg);
  82         case SCM_ARG7:
  83           scm_wrong_type_arg (s_subr, 7, arg);
  84         case SCM_WNA:
  85           scm_wrong_num_args (arg);
  86         case SCM_OUTOFRANGE:
  87           scm_out_of_range (s_subr, arg);
  88         case SCM_NALLOC:
  89           scm_memory_error (s_subr);
  90         default:
  91           /* this shouldn't happen.  */
  92           scm_misc_error (s_subr, "Unknown error", SCM_EOL);
  93         }
  94     }
  95   return SCM_UNSPECIFIED;
  96 }
  97
  98 /* Module registry
  99  */
 100
 101 /* We can't use SCM objects here. One should be able to call
 102    SCM_REGISTER_MODULE from a C++ constructor for a static
 103    object. This happens before main and thus before libguile is
 104    initialized. */
 105
 106 struct moddata {
 107   struct moddata *link;
 108   char *module_name;
 109   void *init_func;
 110 };
 111
 112 static struct moddata *registered_mods = NULL;
 113
 114 void
 115 scm_register_module_xxx (char *module_name, void *init_func)
 116 {
 117   struct moddata *md;
 118
 119   scm_c_issue_deprecation_warning
 120     ("`scm_register_module_xxx' is deprecated.  Use extensions instead.");
 121
 122   /* XXX - should we (and can we) DEFER_INTS here? */
 123
 124   for (md = registered_mods; md; md = md->link)
 125     if (!strcmp (md->module_name, module_name))
 126       {
 127         md->init_func = init_func;
 128         return;
 129       }
 130
 131   md = (struct moddata *) malloc (sizeof (struct moddata));
 132   if (md == NULL)
 133     {
 134       fprintf (stderr,
 135                "guile: can't register module (%s): not enough memory",
 136                module_name);
 137       return;
 138     }
 139
 140   md->module_name = module_name;
 141   md->init_func = init_func;
 142   md->link = registered_mods;
 143   registered_mods = md;
 144 }
 145
 146 SCM_DEFINE (scm_registered_modules, "c-registered-modules", 0, 0, 0,
 147             (),
 148             "Return a list of the object code modules that have been imported into\n"
 149             "the current Guile process.  Each element of the list is a pair whose\n"
 150             "car is the name of the module, and whose cdr is the function handle\n"
 151             "for that module's initializer function.  The name is the string that\n"
 152             "has been passed to scm_register_module_xxx.")
 153 #define FUNC_NAME s_scm_registered_modules
 154 {
 155   SCM res;
 156   struct moddata *md;
 157
 158   res = SCM_EOL;
 159   for (md = registered_mods; md; md = md->link)
 160     res = scm_cons (scm_cons (scm_makfrom0str (md->module_name),
 161                               scm_ulong2num ((unsigned long) md->init_func)),
 162                     res);
 163   return res;
 164 }
 165 #undef FUNC_NAME
 166
 167 SCM_DEFINE (scm_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0,
 168             (),
 169             "Destroy the list of modules registered with the current Guile process.\n"
 170             "The return value is unspecified.  @strong{Warning:} this function does\n"
 171             "not actually unlink or deallocate these modules, but only destroys the\n"
 172             "records of which modules have been loaded.  It should therefore be used\n"
 173             "only by module bookkeeping operations.")
 174 #define FUNC_NAME s_scm_clear_registered_modules
 175 {
 176   struct moddata *md1, *md2;
 177
 178   SCM_DEFER_INTS;
 179
 180   for (md1 = registered_mods; md1; md1 = md2)
 181     {
 182       md2 = md1->link;
 183       free (md1);
 184     }
 185   registered_mods = NULL;
 186
 187   SCM_ALLOW_INTS;
 188   return SCM_UNSPECIFIED;
 189 }
 190 #undef FUNC_NAME
 191
 192 void
 193 scm_remember (SCM *ptr)
 194 {
 195   scm_c_issue_deprecation_warning ("`scm_remember' is deprecated. "
 196                                    "Use the `scm_remember_upto_here*' family of functions instead.");
 197 }
 198
 199 SCM
 200 scm_protect_object (SCM obj)
 201 {
 202   scm_c_issue_deprecation_warning ("`scm_protect_object' is deprecated. "
 203                                    "Use `scm_gc_protect_object' instead.");
 204   return scm_gc_protect_object (obj);
 205 }
 206
 207 SCM
 208 scm_unprotect_object (SCM obj)
 209 {
 210   scm_c_issue_deprecation_warning ("`scm_unprotect_object' is deprecated. "
 211                                    "Use `scm_gc_unprotect_object' instead.");
 212   return scm_gc_unprotect_object (obj);
 213 }
 214
 215 SCM_SYMBOL (scm_sym_app, "app");
 216 SCM_SYMBOL (scm_sym_modules, "modules");
 217 static SCM module_prefix = SCM_BOOL_F;
 218 static SCM make_modules_in_var;
 219 static SCM beautify_user_module_x_var;
 220 static SCM try_module_autoload_var;
 221
 222 static void
 223 init_module_stuff ()
 224 {
 225 #define PERM(x) scm_permanent_object(x)
 226
 227   if (module_prefix == SCM_BOOL_F)
 228     {
 229       module_prefix = PERM (scm_list_2 (scm_sym_app, scm_sym_modules));
 230       make_modules_in_var = PERM (scm_c_lookup ("make-modules-in"));
 231       beautify_user_module_x_var =
 232         PERM (scm_c_lookup ("beautify-user-module!"));
 233       try_module_autoload_var = PERM (scm_c_lookup ("try-module-autoload"));
 234     }
 235 }
 236
 237 SCM
 238 scm_the_root_module ()
 239 {
 240   init_module_stuff ();
 241   scm_c_issue_deprecation_warning ("`scm_the_root_module' is deprecated. "
 242                                    "Use `scm_c_resolve_module (\"guile\")' "
 243                                    "instead.");
 244
 245   return scm_c_resolve_module ("guile");
 246 }
 247
 248 static SCM
 249 scm_module_full_name (SCM name)
 250 {
 251   init_module_stuff ();
 252   if (SCM_EQ_P (SCM_CAR (name), scm_sym_app))
 253     return name;
 254   else
 255     return scm_append (scm_list_2 (module_prefix, name));
 256 }
 257
 258 SCM
 259 scm_make_module (SCM name)
 260 {
 261   init_module_stuff ();
 262   scm_c_issue_deprecation_warning ("`scm_make_module' is deprecated. "
 263                                    "Use `scm_c_define_module instead.");
 264
 265   return scm_call_2 (SCM_VARIABLE_REF (make_modules_in_var),
 266                      scm_the_root_module (),
 267                      scm_module_full_name (name));
 268 }
 269
 270 SCM
 271 scm_ensure_user_module (SCM module)
 272 {
 273   init_module_stuff ();
 274   scm_c_issue_deprecation_warning ("`scm_ensure_user_module' is deprecated. "
 275                                    "Use `scm_c_define_module instead.");
 276
 277   scm_call_1 (SCM_VARIABLE_REF (beautify_user_module_x_var), module);
 278   return SCM_UNSPECIFIED;
 279 }
 280
 281 SCM
 282 scm_load_scheme_module (SCM name)
 283 {
 284   init_module_stuff ();
 285   scm_c_issue_deprecation_warning ("`scm_load_scheme_module' is deprecated. "
 286                                    "Use `scm_c_resolve_module instead.");
 287
 288   return scm_call_1 (SCM_VARIABLE_REF (try_module_autoload_var), name);
 289 }
 290
 291 /* This is implemented in C solely for SCM_COERCE_OUTPORT ... */
 292
 293 static void
 294 maybe_close_port (void *data, SCM port)
 295 {
 296   SCM except = (SCM)data;
 297
 298   while (!SCM_NULLP (except))
 299     {
 300       SCM p = SCM_COERCE_OUTPORT (SCM_CAR (except));
 301       if (SCM_EQ_P (p, port))
 302         return;
 303       except = SCM_CDR (except);
 304     }
 305
 306   scm_close_port (port);
 307 }
 308
 309 SCM_DEFINE (scm_close_all_ports_except, "close-all-ports-except", 0, 0, 1,
 310            (SCM ports),
 311             "[DEPRECATED] Close all open file ports used by the interpreter\n"
 312             "except for those supplied as arguments.  This procedure\n"
 313             "was intended to be used before an exec call to close file descriptors\n"
 314             "which are not needed in the new process.  However it has the\n"
 315             "undesirable side effect of flushing buffers, so it's deprecated.\n"
 316             "Use port-for-each instead.")
 317 #define FUNC_NAME s_scm_close_all_ports_except
 318 {
 319   SCM p;
 320   SCM_VALIDATE_REST_ARGUMENT (ports);
 321
 322   for (p = ports; !SCM_NULLP (p); p = SCM_CDR (p))
 323     SCM_VALIDATE_OPPORT (SCM_ARG1, SCM_COERCE_OUTPORT (SCM_CAR (p)));
 324
 325   scm_c_port_for_each (maybe_close_port, ports);
 326
 327   return SCM_UNSPECIFIED;
 328 }
 329 #undef FUNC_NAME
 330
 331 SCM_DEFINE (scm_variable_set_name_hint, "variable-set-name-hint!", 2, 0, 0,
 332             (SCM var, SCM hint),
 333             "Do not use this function.")
 334 #define FUNC_NAME s_scm_variable_set_name_hint
 335 {
 336   SCM_VALIDATE_VARIABLE (1, var);
 337   SCM_VALIDATE_SYMBOL (2, hint);
 338   scm_c_issue_deprecation_warning
 339     ("'variable-set-name-hint!' is deprecated.  Do not use it.");
 340   return SCM_UNSPECIFIED;
 341 }
 342 #undef FUNC_NAME
 343
 344 SCM_DEFINE (scm_builtin_variable, "builtin-variable", 1, 0, 0,
 345             (SCM name),
 346             "Do not use this function.")
 347 #define FUNC_NAME s_scm_builtin_variable
 348 {
 349   SCM_VALIDATE_SYMBOL (1,name);
 350   scm_c_issue_deprecation_warning ("`builtin-variable' is deprecated. "
 351                                    "Use module system operations instead.");
 352   return scm_sym2var (name, SCM_BOOL_F, SCM_BOOL_T);
 353 }
 354 #undef FUNC_NAME
 355
 356 SCM
 357 scm_makstr (size_t len, int dummy)
 358 {
 359   scm_c_issue_deprecation_warning
 360     ("'scm_makstr' is deprecated.  Use 'scm_allocate_string' instead.");
 361   return scm_allocate_string (len);
 362 }
 363
 364 SCM
 365 scm_makfromstr (const char *src, size_t len, int dummy SCM_UNUSED)
 366 {
 367   scm_c_issue_deprecation_warning ("`scm_makfromstr' is deprecated. "
 368                                    "Use `scm_mem2string' instead.");
 369
 370   return scm_mem2string (src, len);
 371 }
 372
 373 SCM
 374 scm_internal_with_fluids (SCM fluids, SCM values, SCM (*cproc) (), void *cdata)
 375 {
 376   scm_c_issue_deprecation_warning ("`scm_internal_with_fluids' is deprecated. "
 377                                    "Use `scm_c_with_fluids' instead.");
 378
 379   return scm_c_with_fluids (fluids, values, cproc, cdata);
 380 }
 381
 382 SCM
 383 scm_make_gsubr (const char *name, int req, int opt, int rst, SCM (*fcn)())
 384 {
 385   scm_c_issue_deprecation_warning
 386     ("`scm_make_gsubr' is deprecated.  Use `scm_c_define_gsubr' instead.");
 387
 388   return scm_c_define_gsubr (name, req, opt, rst, fcn);
 389 }
 390
 391 SCM
 392 scm_make_gsubr_with_generic (const char *name,
 393                              int req, int opt, int rst,
 394                              SCM (*fcn)(), SCM *gf)
 395 {
 396   scm_c_issue_deprecation_warning
 397     ("`scm_make_gsubr_with_generic' is deprecated.  "
 398      "Use `scm_c_define_gsubr_with_generic' instead.");
 399
 400   return scm_c_define_gsubr_with_generic (name, req, opt, rst, fcn, gf);
 401 }
 402
 403 SCM
 404 scm_create_hook (const char *name, int n_args)
 405 {
 406   scm_c_issue_deprecation_warning
 407     ("'scm_create_hook' is deprecated.  "
 408      "Use 'scm_make_hook' and 'scm_c_define' instead.");
 409   {
 410     SCM hook = scm_make_hook (SCM_MAKINUM (n_args));
 411     scm_c_define (name, hook);
 412     return scm_permanent_object (hook);
 413   }
 414 }
 415
 416 SCM_DEFINE (scm_sloppy_memq, "sloppy-memq", 2, 0, 0,
 417             (SCM x, SCM lst),
 418             "This procedure behaves like @code{memq}, but does no type or error checking.\n"
 419             "Its use is recommended only in writing Guile internals,\n"
 420             "not for high-level Scheme programs.")
 421 #define FUNC_NAME s_scm_sloppy_memq
 422 {
 423   scm_c_issue_deprecation_warning
 424     ("'sloppy-memq' is deprecated.  Use 'memq' instead.");
 425
 426   for(;  SCM_CONSP (lst);  lst = SCM_CDR(lst))
 427     {
 428       if (SCM_EQ_P (SCM_CAR (lst), x))
 429         return lst;
 430     }
 431   return lst;
 432 }
 433 #undef FUNC_NAME
 434
 435
 436 SCM_DEFINE (scm_sloppy_memv, "sloppy-memv", 2, 0, 0,
 437             (SCM x, SCM lst),
 438             "This procedure behaves like @code{memv}, but does no type or error checking.\n"
 439             "Its use is recommended only in writing Guile internals,\n"
 440             "not for high-level Scheme programs.")
 441 #define FUNC_NAME s_scm_sloppy_memv
 442 {
 443   scm_c_issue_deprecation_warning
 444     ("'sloppy-memv' is deprecated.  Use 'memv' instead.");
 445
 446   for(;  SCM_CONSP (lst);  lst = SCM_CDR(lst))
 447     {
 448       if (! SCM_FALSEP (scm_eqv_p (SCM_CAR (lst), x)))
 449         return lst;
 450     }
 451   return lst;
 452 }
 453 #undef FUNC_NAME
 454
 455
 456 SCM_DEFINE (scm_sloppy_member, "sloppy-member", 2, 0, 0,
 457             (SCM x, SCM lst),
 458             "This procedure behaves like @code{member}, but does no type or error checking.\n"
 459             "Its use is recommended only in writing Guile internals,\n"
 460             "not for high-level Scheme programs.")
 461 #define FUNC_NAME s_scm_sloppy_member
 462 {
 463   scm_c_issue_deprecation_warning
 464     ("'sloppy-member' is deprecated.  Use 'member' instead.");
 465
 466   for(;  SCM_CONSP (lst);  lst = SCM_CDR(lst))
 467     {
 468       if (! SCM_FALSEP (scm_equal_p (SCM_CAR (lst), x)))
 469         return lst;
 470     }
 471   return lst;
 472 }
 473 #undef FUNC_NAME
 474
 475 SCM_SYMBOL (scm_end_of_file_key, "end-of-file");
 476
 477 SCM_DEFINE (scm_read_and_eval_x, "read-and-eval!", 0, 1, 0,
 478             (SCM port),
 479             "Read a form from @var{port} (standard input by default), and evaluate it\n"
 480             "(memoizing it in the process) in the top-level environment.  If no data\n"
 481             "is left to be read from @var{port}, an @code{end-of-file} error is\n"
 482             "signalled.")
 483 #define FUNC_NAME s_scm_read_and_eval_x
 484 {
 485   scm_c_issue_deprecation_warning
 486     ("'read-and-eval!' is deprecated.  Use 'read' and 'eval' instead.");
 487
 488   SCM form = scm_read (port);
 489   if (SCM_EOF_OBJECT_P (form))
 490     scm_ithrow (scm_end_of_file_key, SCM_EOL, 1);
 491   return scm_eval_x (form, scm_current_module ());
 492 }
 493 #undef FUNC_NAME
 494
 495 void
 496 scm_i_init_deprecated ()
 497 {
 498 #include "libguile/deprecated.x"
 499 }
 500
 501 #endif