← Back to branch summary

~peter-pearse/ubuntu/natty/guile-1.8/prop001

« back to all changes in this revision

Viewing changes to libguile/hooks.c

  • Committer: Bazaar Package Importer
  • Author(s): Daniel Schepler
  • Date: 2006-11-09 03:11:16 UTC
  • Revision ID: james.westby@ubuntu.com-20061109031116-hu0q1jxqg12y6yeg
Tags: upstream-1.8.1+1
Import upstream version 1.8.1+1

Show diffs side-by-side

added added

removed removed

Lines of Context:
libguile/hooks.c
 
1
/* Copyright (C) 1995,1996,1998,1999,2000,2001, 2003, 2006 Free Software Foundation, Inc.
 
2
 * 
 
3
 * This library is free software; you can redistribute it and/or
 
4
 * modify it under the terms of the GNU Lesser General Public
 
5
 * License as published by the Free Software Foundation; either
 
6
 * version 2.1 of the License, or (at your option) any later version.
 
7
 *
 
8
 * This library 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 GNU
 
11
 * Lesser General Public License for more details.
 
12
 *
 
13
 * You should have received a copy of the GNU Lesser General Public
 
14
 * License along with this library; if not, write to the Free Software
 
15
 * Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
 
16
 */
 
17
 
 
18
 
 
19
 
 
20
 
 
21
#include <stdio.h>
 
22
#include "libguile/_scm.h"
 
23
 
 
24
#include "libguile/eval.h"
 
25
#include "libguile/ports.h"
 
26
#include "libguile/procprop.h"
 
27
#include "libguile/root.h"
 
28
#include "libguile/smob.h"
 
29
#include "libguile/strings.h"
 
30
 
 
31
#include "libguile/validate.h"
 
32
#include "libguile/hooks.h"
 
33
 
 
34
 
 
35
/* C level hooks
 
36
 *
 
37
 * Currently, this implementation is separate from the Scheme level
 
38
 * hooks.  The possibility exists to implement the Scheme level hooks
 
39
 * using C level hooks.
 
40
 */
 
41
 
 
42
void
 
43
scm_c_hook_init (scm_t_c_hook *hook, void *hook_data, scm_t_c_hook_type type)
 
44
{
 
45
  hook->first = 0;
 
46
  hook->type = type;
 
47
  hook->data = hook_data;
 
48
}
 
49
 
 
50
void
 
51
scm_c_hook_add (scm_t_c_hook *hook,
 
52
                scm_t_c_hook_function func,
 
53
                void *func_data, 
 
54
                int appendp)
 
55
{
 
56
  scm_t_c_hook_entry *entry = scm_malloc (sizeof (scm_t_c_hook_entry));
 
57
  scm_t_c_hook_entry **loc = &hook->first;
 
58
  if (appendp)
 
59
    while (*loc)
 
60
      loc = &(*loc)->next;
 
61
  entry->next = *loc;
 
62
  entry->func = func;
 
63
  entry->data = func_data;
 
64
  *loc = entry;
 
65
}
 
66
 
 
67
void
 
68
scm_c_hook_remove (scm_t_c_hook *hook,
 
69
                   scm_t_c_hook_function func,
 
70
                   void *func_data)
 
71
{
 
72
  scm_t_c_hook_entry **loc = &hook->first;
 
73
  while (*loc)
 
74
    {
 
75
      if ((*loc)->func == func && (*loc)->data == func_data)
 
76
        {
 
77
          scm_t_c_hook_entry *entry = *loc;
 
78
          *loc = (*loc)->next;
 
79
          free (entry);
 
80
          return;
 
81
        }
 
82
      loc = &(*loc)->next;
 
83
    }
 
84
  fprintf (stderr, "Attempt to remove non-existent hook function\n");
 
85
  abort ();
 
86
}
 
87
 
 
88
void *
 
89
scm_c_hook_run (scm_t_c_hook *hook, void *data)
 
90
{
 
91
  scm_t_c_hook_entry *entry = hook->first;
 
92
  scm_t_c_hook_type type = hook->type;
 
93
  void *res = 0;
 
94
  while (entry)
 
95
    {
 
96
      res = (entry->func) (hook->data, entry->data, data);
 
97
      if (res)
 
98
        {
 
99
          if (type == SCM_C_HOOK_OR)
 
100
            break;
 
101
        }
 
102
      else
 
103
        {
 
104
          if (type == SCM_C_HOOK_AND)
 
105
            break;
 
106
        }
 
107
      entry = entry->next;
 
108
    }
 
109
  return res;
 
110
}
 
111
 
 
112
 
 
113
/* Scheme level hooks
 
114
 *
 
115
 * A hook is basically a list of procedures to be called at well defined
 
116
 * points in time.
 
117
 *
 
118
 * Hook arity is not a full member of this type and therefore lacks an
 
119
 * accessor.  It exists to aid debugging and is not intended to be used in
 
120
 * programs.
 
121
 */
 
122
 
 
123
scm_t_bits scm_tc16_hook;
 
124
 
 
125
 
 
126
static int
 
127
hook_print (SCM hook, SCM port, scm_print_state *pstate)
 
128
{
 
129
  SCM ls, name;
 
130
  scm_puts ("#<hook ", port);
 
131
  scm_intprint (SCM_HOOK_ARITY (hook), 10, port);
 
132
  scm_putc (' ', port);
 
133
  scm_uintprint (SCM_UNPACK (hook), 16, port);
 
134
  ls = SCM_HOOK_PROCEDURES (hook);
 
135
  while (SCM_NIMP (ls))
 
136
    {
 
137
      scm_putc (' ', port);
 
138
      name = scm_procedure_name (SCM_CAR (ls));
 
139
      if (scm_is_true (name))
 
140
        scm_iprin1 (name, port, pstate);
 
141
      else
 
142
        scm_putc ('?', port);
 
143
      ls = SCM_CDR (ls);
 
144
    }
 
145
  scm_putc ('>', port);
 
146
  return 1;
 
147
}
 
148
 
 
149
 
 
150
SCM_DEFINE (scm_make_hook, "make-hook", 0, 1, 0, 
 
151
            (SCM n_args),
 
152
            "Create a hook for storing procedure of arity @var{n_args}.\n"
 
153
            "@var{n_args} defaults to zero.  The returned value is a hook\n"
 
154
            "object to be used with the other hook procedures.")
 
155
#define FUNC_NAME s_scm_make_hook
 
156
{
 
157
  unsigned int n;
 
158
 
 
159
  if (SCM_UNBNDP (n_args))
 
160
    n = 0;
 
161
  else
 
162
    n = scm_to_unsigned_integer (n_args, 0, 16);
 
163
  
 
164
  SCM_RETURN_NEWSMOB (scm_tc16_hook + (n << 16), SCM_UNPACK (SCM_EOL));
 
165
}
 
166
#undef FUNC_NAME
 
167
 
 
168
 
 
169
SCM_DEFINE (scm_hook_p, "hook?", 1, 0, 0, 
 
170
            (SCM x),
 
171
            "Return @code{#t} if @var{x} is a hook, @code{#f} otherwise.")
 
172
#define FUNC_NAME s_scm_hook_p
 
173
{
 
174
  return scm_from_bool (SCM_HOOKP (x));
 
175
}
 
176
#undef FUNC_NAME
 
177
 
 
178
 
 
179
SCM_DEFINE (scm_hook_empty_p, "hook-empty?", 1, 0, 0, 
 
180
            (SCM hook),
 
181
            "Return @code{#t} if @var{hook} is an empty hook, @code{#f}\n"
 
182
            "otherwise.")
 
183
#define FUNC_NAME s_scm_hook_empty_p
 
184
{
 
185
  SCM_VALIDATE_HOOK (1, hook);
 
186
  return scm_from_bool (scm_is_null (SCM_HOOK_PROCEDURES (hook)));
 
187
}
 
188
#undef FUNC_NAME
 
189
 
 
190
 
 
191
SCM_DEFINE (scm_add_hook_x, "add-hook!", 2, 1, 0, 
 
192
            (SCM hook, SCM proc, SCM append_p),
 
193
            "Add the procedure @var{proc} to the hook @var{hook}. The\n"
 
194
            "procedure is added to the end if @var{append_p} is true,\n"
 
195
            "otherwise it is added to the front.  The return value of this\n"
 
196
            "procedure is not specified.")
 
197
#define FUNC_NAME s_scm_add_hook_x
 
198
{
 
199
  SCM arity, rest;
 
200
  int n_args;
 
201
  SCM_VALIDATE_HOOK (1, hook);
 
202
  SCM_ASSERT (scm_is_true (arity = scm_i_procedure_arity (proc)),
 
203
              proc, SCM_ARG2, FUNC_NAME);
 
204
  n_args = SCM_HOOK_ARITY (hook);
 
205
  if (scm_to_int (SCM_CAR (arity)) > n_args
 
206
      || (scm_is_false (SCM_CADDR (arity))
 
207
          && (scm_to_int (SCM_CAR (arity)) + scm_to_int (SCM_CADR (arity))
 
208
              < n_args)))
 
209
    scm_wrong_type_arg (FUNC_NAME, 2, proc);
 
210
  rest = scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook));
 
211
  SCM_SET_HOOK_PROCEDURES (hook,
 
212
                           (!SCM_UNBNDP (append_p) && scm_is_true (append_p)
 
213
                            ? scm_append_x (scm_list_2 (rest, scm_list_1 (proc)))
 
214
                            : scm_cons (proc, rest)));
 
215
  return SCM_UNSPECIFIED;
 
216
}
 
217
#undef FUNC_NAME
 
218
 
 
219
 
 
220
SCM_DEFINE (scm_remove_hook_x, "remove-hook!", 2, 0, 0, 
 
221
            (SCM hook, SCM proc),
 
222
            "Remove the procedure @var{proc} from the hook @var{hook}.  The\n"
 
223
            "return value of this procedure is not specified.")
 
224
#define FUNC_NAME s_scm_remove_hook_x
 
225
{
 
226
  SCM_VALIDATE_HOOK (1, hook);
 
227
  SCM_SET_HOOK_PROCEDURES (hook,
 
228
                           scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook)));
 
229
  return SCM_UNSPECIFIED;
 
230
}
 
231
#undef FUNC_NAME
 
232
 
 
233
 
 
234
SCM_DEFINE (scm_reset_hook_x, "reset-hook!", 1, 0, 0, 
 
235
            (SCM hook),
 
236
            "Remove all procedures from the hook @var{hook}.  The return\n"
 
237
            "value of this procedure is not specified.")
 
238
#define FUNC_NAME s_scm_reset_hook_x
 
239
{
 
240
  SCM_VALIDATE_HOOK (1, hook);
 
241
  SCM_SET_HOOK_PROCEDURES (hook, SCM_EOL);
 
242
  return SCM_UNSPECIFIED;
 
243
}
 
244
#undef FUNC_NAME
 
245
 
 
246
 
 
247
SCM_DEFINE (scm_run_hook, "run-hook", 1, 0, 1, 
 
248
            (SCM hook, SCM args),
 
249
            "Apply all procedures from the hook @var{hook} to the arguments\n"
 
250
            "@var{args}.  The order of the procedure application is first to\n"
 
251
            "last.  The return value of this procedure is not specified.")
 
252
#define FUNC_NAME s_scm_run_hook
 
253
{
 
254
  SCM_VALIDATE_HOOK (1, hook);
 
255
  if (scm_ilength (args) != SCM_HOOK_ARITY (hook))
 
256
    SCM_MISC_ERROR ("Hook ~S requires ~A arguments",
 
257
                    scm_list_2 (hook, scm_from_int (SCM_HOOK_ARITY (hook))));
 
258
  scm_c_run_hook (hook, args);
 
259
  return SCM_UNSPECIFIED;
 
260
}
 
261
#undef FUNC_NAME
 
262
 
 
263
 
 
264
void
 
265
scm_c_run_hook (SCM hook, SCM args)
 
266
{
 
267
  SCM procs = SCM_HOOK_PROCEDURES (hook);
 
268
  while (SCM_NIMP (procs))
 
269
    {
 
270
      scm_apply_0 (SCM_CAR (procs), args);
 
271
      procs = SCM_CDR (procs);
 
272
    }
 
273
}
 
274
 
 
275
 
 
276
SCM_DEFINE (scm_hook_to_list, "hook->list", 1, 0, 0, 
 
277
            (SCM hook),
 
278
            "Convert the procedure list of @var{hook} to a list.")
 
279
#define FUNC_NAME s_scm_hook_to_list
 
280
{
 
281
  SCM_VALIDATE_HOOK (1, hook);
 
282
  return scm_list_copy (SCM_HOOK_PROCEDURES (hook));
 
283
}
 
284
#undef FUNC_NAME
 
285
 
 
286
 
 
287
 
 
288
 
 
289
void
 
290
scm_init_hooks ()
 
291
{
 
292
  scm_tc16_hook = scm_make_smob_type ("hook", 0);
 
293
  scm_set_smob_mark (scm_tc16_hook, scm_markcdr);
 
294
  scm_set_smob_print (scm_tc16_hook, hook_print);
 
295
#include "libguile/hooks.x"
 
296
}
 
297
 
 
298
/*
 
299
  Local Variables:
 
300
  c-file-style: "gnu"
 
301
  End:
 
302
*/