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
  40 #include <stdio.h>
  41 #include <string.h>
  42
  43 #if (SCM_ENABLE_DEPRECATED == 1)
  44
  45 SCM_REGISTER_PROC(s_substring_move_left_x, "substring-move-left!", 5, 0, 0, scm_substring_move_x);
  46
  47 SCM_REGISTER_PROC(s_substring_move_right_x, "substring-move-right!", 5, 0, 0, scm_substring_move_x);
  48
  49 SCM
  50 scm_wta (SCM arg, const char *pos, const char *s_subr)
  51 {
  52   if (!s_subr || !*s_subr)
  53     s_subr = NULL;
  54   if ((~0x1fL) & (long) pos)
  55     {
  56       /* error string supplied.  */
  57       scm_misc_error (s_subr, pos, scm_list_1 (arg));
  58     }
  59   else
  60     {
  61       /* numerical error code.  */
  62       scm_t_bits error = (scm_t_bits) pos;
  63
  64       switch (error)
  65         {
  66         case SCM_ARGn:
  67           scm_wrong_type_arg (s_subr, 0, arg);
  68         case SCM_ARG1:
  69           scm_wrong_type_arg (s_subr, 1, arg);
  70         case SCM_ARG2:
  71           scm_wrong_type_arg (s_subr, 2, arg);
  72         case SCM_ARG3:
  73           scm_wrong_type_arg (s_subr, 3, arg);
  74         case SCM_ARG4:
  75           scm_wrong_type_arg (s_subr, 4, arg);
  76         case SCM_ARG5:
  77           scm_wrong_type_arg (s_subr, 5, arg);
  78         case SCM_ARG6:
  79           scm_wrong_type_arg (s_subr, 6, arg);
  80         case SCM_ARG7:
  81           scm_wrong_type_arg (s_subr, 7, arg);
  82         case SCM_WNA:
  83           scm_wrong_num_args (arg);
  84         case SCM_OUTOFRANGE:
  85           scm_out_of_range (s_subr, arg);
  86         case SCM_NALLOC:
  87           scm_memory_error (s_subr);
  88         default:
  89           /* this shouldn't happen.  */
  90           scm_misc_error (s_subr, "Unknown error", SCM_EOL);
  91         }
  92     }
  93   return SCM_UNSPECIFIED;
  94 }
  95
  96 /* Module registry
  97  */
  98
  99 /* We can't use SCM objects here. One should be able to call
 100    SCM_REGISTER_MODULE from a C++ constructor for a static
 101    object. This happens before main and thus before libguile is
 102    initialized. */
 103
 104 struct moddata {
 105   struct moddata *link;
 106   char *module_name;
 107   void *init_func;
 108 };
 109
 110 static struct moddata *registered_mods = NULL;
 111
 112 void
 113 scm_register_module_xxx (char *module_name, void *init_func)
 114 {
 115   struct moddata *md;
 116
 117   scm_c_issue_deprecation_warning
 118     ("`scm_register_module_xxx' is deprecated.  Use extensions instead.");
 119
 120   /* XXX - should we (and can we) DEFER_INTS here? */
 121
 122   for (md = registered_mods; md; md = md->link)
 123     if (!strcmp (md->module_name, module_name))
 124       {
 125         md->init_func = init_func;
 126         return;
 127       }
 128
 129   md = (struct moddata *) malloc (sizeof (struct moddata));
 130   if (md == NULL)
 131     {
 132       fprintf (stderr,
 133                "guile: can't register module (%s): not enough memory",
 134                module_name);
 135       return;
 136     }
 137
 138   md->module_name = module_name;
 139   md->init_func = init_func;
 140   md->link = registered_mods;
 141   registered_mods = md;
 142 }
 143
 144 SCM_DEFINE (scm_registered_modules, "c-registered-modules", 0, 0, 0,
 145             (),
 146             "Return a list of the object code modules that have been imported into\n"
 147             "the current Guile process.  Each element of the list is a pair whose\n"
 148             "car is the name of the module, and whose cdr is the function handle\n"
 149             "for that module's initializer function.  The name is the string that\n"
 150             "has been passed to scm_register_module_xxx.")
 151 #define FUNC_NAME s_scm_registered_modules
 152 {
 153   SCM res;
 154   struct moddata *md;
 155
 156   res = SCM_EOL;
 157   for (md = registered_mods; md; md = md->link)
 158     res = scm_cons (scm_cons (scm_makfrom0str (md->module_name),
 159                               scm_ulong2num ((unsigned long) md->init_func)),
 160                     res);
 161   return res;
 162 }
 163 #undef FUNC_NAME
 164
 165 SCM_DEFINE (scm_clear_registered_modules, "c-clear-registered-modules", 0, 0, 0,
 166             (),
 167             "Destroy the list of modules registered with the current Guile process.\n"
 168             "The return value is unspecified.  @strong{Warning:} this function does\n"
 169             "not actually unlink or deallocate these modules, but only destroys the\n"
 170             "records of which modules have been loaded.  It should therefore be used\n"
 171             "only by module bookkeeping operations.")
 172 #define FUNC_NAME s_scm_clear_registered_modules
 173 {
 174   struct moddata *md1, *md2;
 175
 176   SCM_DEFER_INTS;
 177
 178   for (md1 = registered_mods; md1; md1 = md2)
 179     {
 180       md2 = md1->link;
 181       free (md1);
 182     }
 183   registered_mods = NULL;
 184
 185   SCM_ALLOW_INTS;
 186   return SCM_UNSPECIFIED;
 187 }
 188 #undef FUNC_NAME
 189
 190 void
 191 scm_remember (SCM *ptr)
 192 {
 193   scm_c_issue_deprecation_warning ("`scm_remember' is deprecated. "
 194                                    "Use the `scm_remember_upto_here*' family of functions instead.");
 195 }
 196
 197 SCM
 198 scm_protect_object (SCM obj)
 199 {
 200   scm_c_issue_deprecation_warning ("`scm_protect_object' is deprecated. "
 201                                    "Use `scm_gc_protect_object' instead.");
 202   return scm_gc_protect_object (obj);
 203 }
 204
 205 SCM
 206 scm_unprotect_object (SCM obj)
 207 {
 208   scm_c_issue_deprecation_warning ("`scm_unprotect_object' is deprecated. "
 209                                    "Use `scm_gc_unprotect_object' instead.");
 210   return scm_gc_unprotect_object (obj);
 211 }
 212
 213 SCM_SYMBOL (scm_sym_app, "app");
 214 SCM_SYMBOL (scm_sym_modules, "modules");
 215 static SCM module_prefix = SCM_BOOL_F;
 216 static SCM make_modules_in_var;
 217 static SCM beautify_user_module_x_var;
 218 static SCM try_module_autoload_var;
 219
 220 static void
 221 init_module_stuff ()
 222 {
 223 #define PERM(x) scm_permanent_object(x)
 224
 225   if (module_prefix == SCM_BOOL_F)
 226     {
 227       module_prefix = PERM (scm_list_2 (scm_sym_app, scm_sym_modules));
 228       make_modules_in_var = PERM (scm_c_lookup ("make-modules-in"));
 229       beautify_user_module_x_var =
 230         PERM (scm_c_lookup ("beautify-user-module!"));
 231       try_module_autoload_var = PERM (scm_c_lookup ("try-module-autoload"));
 232     }
 233 }
 234
 235 SCM
 236 scm_the_root_module ()
 237 {
 238   init_module_stuff ();
 239   scm_c_issue_deprecation_warning ("`scm_the_root_module' is deprecated. "
 240                                    "Use `scm_c_resolve_module (\"guile\")' "
 241                                    "instead.");
 242
 243   return scm_c_resolve_module ("guile");
 244 }
 245
 246 static SCM
 247 scm_module_full_name (SCM name)
 248 {
 249   init_module_stuff ();
 250   if (SCM_EQ_P (SCM_CAR (name), scm_sym_app))
 251     return name;
 252   else
 253     return scm_append (scm_list_2 (module_prefix, name));
 254 }
 255
 256 SCM
 257 scm_make_module (SCM name)
 258 {
 259   init_module_stuff ();
 260   scm_c_issue_deprecation_warning ("`scm_make_module' is deprecated. "
 261                                    "Use `scm_c_define_module instead.");
 262
 263   return scm_call_2 (SCM_VARIABLE_REF (make_modules_in_var),
 264                      scm_the_root_module (),
 265                      scm_module_full_name (name));
 266 }
 267
 268 SCM
 269 scm_ensure_user_module (SCM module)
 270 {
 271   init_module_stuff ();
 272   scm_c_issue_deprecation_warning ("`scm_ensure_user_module' is deprecated. "
 273                                    "Use `scm_c_define_module instead.");
 274
 275   scm_call_1 (SCM_VARIABLE_REF (beautify_user_module_x_var), module);
 276   return SCM_UNSPECIFIED;
 277 }
 278
 279 SCM
 280 scm_load_scheme_module (SCM name)
 281 {
 282   init_module_stuff ();
 283   scm_c_issue_deprecation_warning ("`scm_load_scheme_module' is deprecated. "
 284                                    "Use `scm_c_resolve_module instead.");
 285
 286   return scm_call_1 (SCM_VARIABLE_REF (try_module_autoload_var), name);
 287 }
 288
 289 /* This is implemented in C solely for SCM_COERCE_OUTPORT ... */
 290
 291 static void
 292 maybe_close_port (void *data, SCM port)
 293 {
 294   SCM except = (SCM)data;
 295
 296   while (!SCM_NULLP (except))
 297     {
 298       SCM p = SCM_COERCE_OUTPORT (SCM_CAR (except));
 299       if (SCM_EQ_P (p, port))
 300         return;
 301       except = SCM_CDR (except);
 302     }
 303
 304   scm_close_port (port);
 305 }
 306
 307 SCM_DEFINE (scm_close_all_ports_except, "close-all-ports-except", 0, 0, 1,
 308            (SCM ports),
 309             "[DEPRECATED] Close all open file ports used by the interpreter\n"
 310             "except for those supplied as arguments.  This procedure\n"
 311             "was intended to be used before an exec call to close file descriptors\n"
 312             "which are not needed in the new process.  However it has the\n"
 313             "undesirable side effect of flushing buffers, so it's deprecated.\n"
 314             "Use port-for-each instead.")
 315 #define FUNC_NAME s_scm_close_all_ports_except
 316 {
 317   SCM p;
 318   SCM_VALIDATE_REST_ARGUMENT (ports);
 319
 320   for (p = ports; !SCM_NULLP (p); p = SCM_CDR (p))
 321     SCM_VALIDATE_OPPORT (SCM_ARG1, SCM_COERCE_OUTPORT (SCM_CAR (p)));
 322
 323   scm_c_port_for_each (maybe_close_port, ports);
 324
 325   return SCM_UNSPECIFIED;
 326 }
 327 #undef FUNC_NAME
 328
 329 void
 330 scm_i_init_deprecated ()
 331 {
 332 #include "libguile/deprecated.x"
 333 }
 334
 335 #endif