libguile/hooks.c

   1 /*      Copyright (C) 1995, 1996, 1998, 1999, 2000 Free Software Foundation, Inc.
   2  *
   3  * This program is free software; you can redistribute it and/or modify
   4  * it under the terms of the GNU General Public License as published by
   5  * the Free Software Foundation; either version 2, or (at your option)
   6  * any later version.
   7  *
   8  * This program is distributed in the hope that it will be useful,
   9  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  10  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  11  * GNU General Public License for more details.
  12  *
  13  * You should have received a copy of the GNU General Public License
  14  * along with this software; see the file COPYING.  If not, write to
  15  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  16  * Boston, MA 02111-1307 USA
  17  *
  18  * As a special exception, the Free Software Foundation gives permission
  19  * for additional uses of the text contained in its release of GUILE.
  20  *
  21  * The exception is that, if you link the GUILE library with other files
  22  * to produce an executable, this does not by itself cause the
  23  * resulting executable to be covered by the GNU General Public License.
  24  * Your use of that executable is in no way restricted on account of
  25  * linking the GUILE library code into it.
  26  *
  27  * This exception does not however invalidate any other reasons why
  28  * the executable file might be covered by the GNU General Public License.
  29  *
  30  * This exception applies only to the code released by the
  31  * Free Software Foundation under the name GUILE.  If you copy
  32  * code from other Free Software Foundation releases into a copy of
  33  * GUILE, as the General Public License permits, the exception does
  34  * not apply to the code that you add in this way.  To avoid misleading
  35  * anyone as to the status of such modified files, you must delete
  36  * this exception notice from them.
  37  *
  38  * If you write modifications of your own for GUILE, it is your choice
  39  * whether to permit this exception to apply to your modifications.
  40  * If you do not wish that, delete this exception notice.  */
  41
  42 /* Software engineering face-lift by Greg J. Badros, 11-Dec-1999,
  43    gjb@cs.washington.edu, http://www.cs.washington.edu/homes/gjb */
  44
  45 \f
  46
  47 #include <stdio.h>
  48 #include "libguile/_scm.h"
  49
  50 #include "libguile/eval.h"
  51 #include "libguile/ports.h"
  52 #include "libguile/objprop.h"
  53 #include "libguile/procprop.h"
  54 #include "libguile/root.h"
  55 #include "libguile/smob.h"
  56 #include "libguile/strings.h"
  57
  58 #include "libguile/validate.h"
  59 #include "libguile/hooks.h"
  60
  61 \f
  62 /* C level hooks
  63  *
  64  * Currently, this implementation is separate from the Scheme level
  65  * hooks.  The possibility exists to implement the Scheme level hooks
  66  * using C level hooks.
  67  */
  68
  69 void
  70 scm_c_hook_init (scm_c_hook_t *hook, void *hook_data, scm_c_hook_type_t type)
  71 {
  72   hook->first = 0;
  73   hook->type = type;
  74   hook->data = hook_data;
  75 }
  76
  77 void
  78 scm_c_hook_add (scm_c_hook_t *hook,
  79                 scm_c_hook_function_t func,
  80                 void *func_data,
  81                 int appendp)
  82 {
  83   scm_c_hook_entry_t *entry = scm_must_malloc (sizeof (scm_c_hook_entry_t),
  84                                              "C level hook entry");
  85   scm_c_hook_entry_t **loc = &hook->first;
  86   if (appendp)
  87     while (*loc)
  88       *loc = (*loc)->next;
  89   entry->next = *loc;
  90   entry->func = func;
  91   entry->data = func_data;
  92   *loc = entry;
  93 }
  94
  95 void
  96 scm_c_hook_remove (scm_c_hook_t *hook,
  97                    scm_c_hook_function_t func,
  98                    void *func_data)
  99 {
 100   scm_c_hook_entry_t **loc = &hook->first;
 101   while (*loc)
 102     {
 103       if ((*loc)->func == func && (*loc)->data == func_data)
 104         {
 105           scm_c_hook_entry_t *entry = *loc;
 106           *loc = (*loc)->next;
 107           scm_must_free (entry);
 108           return;
 109         }
 110       loc = &(*loc)->next;
 111     }
 112   fprintf (stderr, "Attempt to remove non-existent hook function\n");
 113   abort ();
 114 }
 115
 116 void *
 117 scm_c_hook_run (scm_c_hook_t *hook, void *data)
 118 {
 119   scm_c_hook_entry_t *entry = hook->first;
 120   scm_c_hook_type_t type = hook->type;
 121   void *res = 0;
 122   while (entry)
 123     {
 124       res = (entry->func) (hook->data, entry->data, data);
 125       if (res)
 126         {
 127           if (type == SCM_C_HOOK_OR)
 128             break;
 129         }
 130       else
 131         {
 132           if (type == SCM_C_HOOK_AND)
 133             break;
 134         }
 135       entry = entry->next;
 136     }
 137   return res;
 138 }
 139
 140 \f
 141 /* Scheme level hooks
 142  *
 143  * A hook is basically a list of procedures to be called at well defined
 144  * points in time.
 145  *
 146  * Hook arity is not a full member of this type and therefore lacks an
 147  * accessor.  It exists to aid debugging and is not intended to be used in
 148  * programs.
 149  */
 150
 151 scm_bits_t scm_tc16_hook;
 152
 153
 154 static SCM
 155 make_hook (SCM n_args, const char *subr)
 156 {
 157   int n;
 158
 159   if (SCM_UNBNDP (n_args))
 160     {
 161       n = 0;
 162     }
 163   else
 164     {
 165       SCM_ASSERT (SCM_INUMP (n_args), n_args, SCM_ARGn, subr);
 166       n = SCM_INUM (n_args);
 167       if (n < 0 || n > 16)
 168         scm_out_of_range (subr, n_args);
 169     }
 170   SCM_RETURN_NEWSMOB (scm_tc16_hook + (n << 16), SCM_UNPACK (SCM_EOL));
 171 }
 172
 173
 174 static int
 175 hook_print (SCM hook, SCM port, scm_print_state *pstate)
 176 {
 177   SCM ls, name;
 178   scm_puts ("#<hook ", port);
 179   scm_intprint (SCM_HOOK_ARITY (hook), 10, port);
 180   scm_putc (' ', port);
 181   scm_intprint (SCM_UNPACK (hook), 16, port);
 182   ls = SCM_HOOK_PROCEDURES (hook);
 183   while (SCM_NIMP (ls))
 184     {
 185       scm_putc (' ', port);
 186       name = scm_procedure_name (SCM_CAR (ls));
 187       if (SCM_NFALSEP (name))
 188         scm_iprin1 (name, port, pstate);
 189       else
 190         scm_putc ('?', port);
 191       ls = SCM_CDR (ls);
 192     }
 193   scm_putc ('>', port);
 194   return 1;
 195 }
 196
 197
 198 SCM_SYMBOL (symbol_name, "name");
 199
 200 SCM
 201 scm_create_hook (const char* name, int n_args)
 202 {
 203   SCM hook = make_hook (SCM_MAKINUM (n_args), "scm_create_hook");
 204   scm_sysintern (name, hook);
 205   scm_set_object_property_x (hook, symbol_name, scm_makfrom0str (name));
 206   scm_protect_object (hook);
 207   return hook;
 208 }
 209
 210
 211 #if (SCM_DEBUG_DEPRECATED == 0)
 212
 213 SCM_DEFINE (scm_make_hook_with_name, "make-hook-with-name", 1, 1, 0,
 214             (SCM name, SCM n_args),
 215             "Create a named hook with the name @var{name} for storing\n"
 216             "procedures of arity @var{n_args}.  @var{n_args} defaults to\n"
 217             "zero.")
 218 #define FUNC_NAME s_scm_make_hook_with_name
 219 {
 220   SCM hook = make_hook (n_args, FUNC_NAME);
 221   scm_set_object_property_x (hook, scm_makfrom0str ("name"), name);
 222   return hook;
 223 }
 224 #undef FUNC_NAME
 225
 226 #endif  /* SCM_DEBUG_DEPRECATED == 0 */
 227
 228
 229 SCM_DEFINE (scm_make_hook, "make-hook", 0, 1, 0,
 230             (SCM n_args),
 231             "Create a hook for storing procedure of arity\n"
 232             "@var{n_args}.  @var{n_args} defaults to zero.")
 233 #define FUNC_NAME s_scm_make_hook
 234 {
 235   return make_hook (n_args, FUNC_NAME);
 236 }
 237 #undef FUNC_NAME
 238
 239
 240 SCM_DEFINE (scm_hook_p, "hook?", 1, 0, 0,
 241             (SCM x),
 242             "Return @code{#t} if @var{x} is a hook, @code{#f} otherwise.")
 243 #define FUNC_NAME s_scm_hook_p
 244 {
 245   return SCM_BOOL (SCM_HOOKP (x));
 246 }
 247 #undef FUNC_NAME
 248
 249
 250 SCM_DEFINE (scm_hook_empty_p, "hook-empty?", 1, 0, 0,
 251             (SCM hook),
 252             "Return @code{#t} if @var{hook} is an empty hook, @code{#f}\n"
 253             "otherwise.")
 254 #define FUNC_NAME s_scm_hook_empty_p
 255 {
 256   SCM_VALIDATE_HOOK (1, hook);
 257   return SCM_BOOL (SCM_NULLP (SCM_HOOK_PROCEDURES (hook)));
 258 }
 259 #undef FUNC_NAME
 260
 261
 262 SCM_DEFINE (scm_add_hook_x, "add-hook!", 2, 1, 0,
 263             (SCM hook, SCM proc, SCM append_p),
 264             "Add the procedure @var{proc} to the hook @var{hook}. The\n"
 265             "procedure is added to the end if @var{append_p} is true,\n"
 266             "otherwise it is added to the front.")
 267 #define FUNC_NAME s_scm_add_hook_x
 268 {
 269   SCM arity, rest;
 270   int n_args;
 271   SCM_VALIDATE_HOOK (1,hook);
 272   SCM_ASSERT (SCM_NFALSEP (arity = scm_i_procedure_arity (proc)),
 273               proc, SCM_ARG2, FUNC_NAME);
 274   n_args = SCM_HOOK_ARITY (hook);
 275   if (SCM_INUM (SCM_CAR (arity)) > n_args
 276       || (SCM_FALSEP (SCM_CADDR (arity))
 277           && (SCM_INUM (SCM_CAR (arity)) + SCM_INUM (SCM_CADR (arity))
 278               < n_args)))
 279     scm_wrong_type_arg (FUNC_NAME, 2, proc);
 280   rest = scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook));
 281   SCM_SET_HOOK_PROCEDURES (hook,
 282                            (!SCM_UNBNDP (append_p) && !SCM_FALSEP (append_p)
 283                             ? scm_append_x (SCM_LIST2 (rest, SCM_LIST1 (proc)))
 284                             : scm_cons (proc, rest)));
 285   return SCM_UNSPECIFIED;
 286 }
 287 #undef FUNC_NAME
 288
 289
 290 SCM_DEFINE (scm_remove_hook_x, "remove-hook!", 2, 0, 0,
 291             (SCM hook, SCM proc),
 292             "Remove the procedure @var{proc} from the hook @var{hook}.")
 293 #define FUNC_NAME s_scm_remove_hook_x
 294 {
 295   SCM_VALIDATE_HOOK (1, hook);
 296   SCM_SET_HOOK_PROCEDURES (hook,
 297                            scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook)));
 298   return SCM_UNSPECIFIED;
 299 }
 300 #undef FUNC_NAME
 301
 302
 303 SCM_DEFINE (scm_reset_hook_x, "reset-hook!", 1, 0, 0,
 304             (SCM hook),
 305             "Remove all procedures from the hook @var{hook}.")
 306 #define FUNC_NAME s_scm_reset_hook_x
 307 {
 308   SCM_VALIDATE_HOOK (1,hook);
 309   SCM_SET_HOOK_PROCEDURES (hook, SCM_EOL);
 310   return SCM_UNSPECIFIED;
 311 }
 312 #undef FUNC_NAME
 313
 314
 315 SCM_DEFINE (scm_run_hook, "run-hook", 1, 0, 1,
 316             (SCM hook, SCM args),
 317             "Apply all procedures from the hook @var{hook} to the arguments\n"
 318             "@var{args}.  The order of the procedure application is first to\n"
 319             "last.")
 320 #define FUNC_NAME s_scm_run_hook
 321 {
 322   SCM_VALIDATE_HOOK (1,hook);
 323   if (scm_ilength (args) != SCM_HOOK_ARITY (hook))
 324     SCM_MISC_ERROR ("Hook ~S requires ~A arguments",
 325                     SCM_LIST2 (hook,SCM_MAKINUM (SCM_HOOK_ARITY (hook))));
 326   scm_c_run_hook (hook, args);
 327   return SCM_UNSPECIFIED;
 328 }
 329 #undef FUNC_NAME
 330
 331
 332 void
 333 scm_c_run_hook (SCM hook, SCM args)
 334 {
 335   SCM procs = SCM_HOOK_PROCEDURES (hook);
 336   while (SCM_NIMP (procs))
 337     {
 338       scm_apply (SCM_CAR (procs), args, SCM_EOL);
 339       procs = SCM_CDR (procs);
 340     }
 341 }
 342
 343
 344 SCM_DEFINE (scm_hook_to_list, "hook->list", 1, 0, 0,
 345             (SCM hook),
 346             "Convert the procedure list of @var{hook} to a list.")
 347 #define FUNC_NAME s_scm_hook_to_list
 348 {
 349   SCM_VALIDATE_HOOK (1, hook);
 350   return scm_list_copy (SCM_HOOK_PROCEDURES (hook));
 351 }
 352 #undef FUNC_NAME
 353
 354
 355 \f
 356
 357 void
 358 scm_init_hooks ()
 359 {
 360   scm_tc16_hook = scm_make_smob_type ("hook", 0);
 361   scm_set_smob_mark (scm_tc16_hook, scm_markcdr);
 362   scm_set_smob_print (scm_tc16_hook, hook_print);
 363 #ifndef SCM_MAGIC_SNARFER
 364 #include "libguile/hooks.x"
 365 #endif
 366 }
 367
 368 /*
 369   Local Variables:
 370   c-file-style: "gnu"
 371   End:
 372 */