diff options
author | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 2000-04-21 23:11:05 +0000 |
---|---|---|
committer | Mikael Djurfeldt <djurfeldt@nada.kth.se> | 2000-04-21 23:11:05 +0000 |
commit | 87694b930cbc3be9b29d3f4a3dd455617b58c32c (patch) | |
tree | 35a4f1046ed78ea3a0f86cea8b3d66b84995ddee | |
parent | 7157d7a90abc706f428147b21ddfd0889b2fb553 (diff) | |
download | guile-87694b930cbc3be9b29d3f4a3dd455617b58c32c.tar.gz |
* feature.c, feature.h: Broke out hook code into separate files.
-rw-r--r-- | libguile/feature.c | 225 | ||||
-rw-r--r-- | libguile/feature.h | 23 |
2 files changed, 2 insertions, 246 deletions
diff --git a/libguile/feature.c b/libguile/feature.c index 7c2598105..e05a10115 100644 --- a/libguile/feature.c +++ b/libguile/feature.c @@ -1,4 +1,4 @@ -/* Copyright (C) 1995, 1996, 1998, 1999 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1998, 1999, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -47,9 +47,6 @@ #include <stdio.h> #include "libguile/_scm.h" -#include "libguile/eval.h" -#include "libguile/ports.h" -#include "libguile/procprop.h" #include "libguile/root.h" #include "libguile/smob.h" #include "libguile/strings.h" @@ -99,222 +96,6 @@ scm_set_program_arguments (int argc, char **argv, char *first) -/* Hooks - * - * A hook is basically a list of procedures to be called at well defined - * points in time. - * - * Hook name and arity are not full members of this type and therefore - * lack accessors. They are added to aid debugging and are not - * intended to be used in programs. - * - */ - -long scm_tc16_hook; - - -static SCM -make_hook (SCM name, SCM n_args, const char *subr) -{ - int n; - SCM_ASSERT (SCM_FALSEP (name) || (SCM_SYMBOLP (name)), - name, - SCM_ARG1, - subr); - if (SCM_UNBNDP (n_args)) - n = 0; - else - { - SCM_ASSERT (SCM_INUMP (n_args), n_args, SCM_ARGn, subr); - n = SCM_INUM (n_args); - } - SCM_ASSERT (n >= 0 && n <= 16, n_args, SCM_OUTOFRANGE, subr); - SCM_RETURN_NEWSMOB (scm_tc16_hook + (n << 16), SCM_UNPACK (SCM_LIST1 (name))); -} - - -static int -print_hook (SCM hook, SCM port, scm_print_state *pstate) -{ - SCM ls, name; - scm_puts ("#<hook ", port); - if (SCM_NFALSEP (SCM_HOOK_NAME (hook))) - { - scm_iprin1 (SCM_HOOK_NAME (hook), port, pstate); - scm_putc (' ', port); - } - scm_intprint (SCM_HOOK_ARITY (hook), 10, port); - scm_putc (' ', port); - scm_intprint (SCM_UNPACK (hook), 16, port); - ls = SCM_HOOK_PROCEDURES (hook); - while (SCM_NIMP (ls)) - { - scm_putc (' ', port); - name = scm_procedure_name (SCM_CAR (ls)); - if (SCM_NFALSEP (name)) - scm_iprin1 (name, port, pstate); - else - scm_putc ('?', port); - ls = SCM_CDR (ls); - } - scm_putc ('>', port); - return 1; -} - - -SCM -scm_create_hook (const char* name, int n_args) -{ - SCM vcell = scm_sysintern0 (name); - SCM hook = make_hook (SCM_CAR (vcell), SCM_MAKINUM (n_args), - "scm_create_hook"); - SCM_SETCDR (vcell, hook); - scm_protect_object (vcell); - return hook; -} - - -/* This function is deprecated. It will be removed in next release. */ -SCM -scm_make_named_hook (const char* name, int n_args) -{ - return scm_create_hook (name, n_args); -} - - -SCM_DEFINE (scm_make_hook_with_name, "make-hook-with-name", 1, 1, 0, - (SCM name, SCM n_args), -"") -#define FUNC_NAME s_scm_make_hook_with_name -{ - return make_hook (name, n_args, FUNC_NAME); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_make_hook, "make-hook", 0, 1, 0, - (SCM n_args), -"") -#define FUNC_NAME s_scm_make_hook -{ - return make_hook (SCM_BOOL_F, n_args, FUNC_NAME); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_hook_p, "hook?", 1, 0, 0, - (SCM x), -"") -#define FUNC_NAME s_scm_hook_p -{ - return SCM_BOOL(SCM_HOOKP (x)); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_hook_empty_p, "hook-empty?", 1, 0, 0, - (SCM hook), -"") -#define FUNC_NAME s_scm_hook_empty_p -{ - SCM_VALIDATE_HOOK (1,hook); - return SCM_BOOL(SCM_NULLP (SCM_HOOK_PROCEDURES (hook))); -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_add_hook_x, "add-hook!", 2, 1, 0, - (SCM hook, SCM proc, SCM append_p), -"") -#define FUNC_NAME s_scm_add_hook_x -{ - SCM arity, rest; - int n_args; - SCM_VALIDATE_HOOK (1,hook); - SCM_ASSERT (SCM_NFALSEP (arity = scm_i_procedure_arity (proc)), - proc, SCM_ARG2, FUNC_NAME); - n_args = SCM_HOOK_ARITY (hook); - if (SCM_INUM (SCM_CAR (arity)) > n_args - || (SCM_FALSEP (SCM_CADDR (arity)) - && (SCM_INUM (SCM_CAR (arity)) + SCM_INUM (SCM_CADR (arity)) - < n_args))) - scm_wrong_type_arg (FUNC_NAME, 2, proc); - rest = scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook)); - SCM_SET_HOOK_PROCEDURES (hook, - (!SCM_UNBNDP (append_p) && SCM_NFALSEP (append_p) - ? scm_append_x (SCM_LIST2 (rest, SCM_LIST1 (proc))) - : scm_cons (proc, rest))); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_remove_hook_x, "remove-hook!", 2, 0, 0, - (SCM hook, SCM proc), -"") -#define FUNC_NAME s_scm_remove_hook_x -{ - SCM_VALIDATE_HOOK (1,hook); - SCM_SET_HOOK_PROCEDURES (hook, - scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook))); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_reset_hook_x, "reset-hook!", 1, 0, 0, - (SCM hook), -"") -#define FUNC_NAME s_scm_reset_hook_x -{ - SCM_VALIDATE_HOOK (1,hook); - SCM_SET_HOOK_PROCEDURES (hook, SCM_EOL); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -SCM_DEFINE (scm_run_hook, "run-hook", 1, 0, 1, - (SCM hook, SCM args), -"") -#define FUNC_NAME s_scm_run_hook -{ - SCM_VALIDATE_HOOK (1,hook); - if (SCM_UNBNDP (args)) - args = SCM_EOL; - if (scm_ilength (args) != SCM_HOOK_ARITY (hook)) - SCM_MISC_ERROR ("Hook ~S requires ~A arguments", - SCM_LIST2 (hook,SCM_MAKINUM (SCM_HOOK_ARITY (hook)))); - scm_c_run_hook (hook, args); - return SCM_UNSPECIFIED; -} -#undef FUNC_NAME - - -void -scm_c_run_hook (SCM hook, SCM args) -{ - SCM procs = SCM_HOOK_PROCEDURES (hook); - while (SCM_NIMP (procs)) - { - scm_apply (SCM_CAR (procs), args, SCM_EOL); - procs = SCM_CDR (procs); - } -} - - -SCM_DEFINE (scm_hook_to_list, "hook->list", 1, 0, 0, - (SCM hook), -"") -#define FUNC_NAME s_scm_hook_to_list -{ - SCM_VALIDATE_HOOK (1,hook); - return scm_list_copy (SCM_HOOK_PROCEDURES (hook)); -} -#undef FUNC_NAME - - - void scm_init_feature() @@ -344,10 +125,6 @@ scm_init_feature() scm_sysintern ("char-code-limit", SCM_MAKINUM (SCM_CHAR_CODE_LIMIT)); - scm_tc16_hook = scm_make_smob_type ("hook", 0); - scm_set_smob_mark (scm_tc16_hook, scm_markcdr); - scm_set_smob_print (scm_tc16_hook, print_hook); - #include "libguile/feature.x" } diff --git a/libguile/feature.h b/libguile/feature.h index 125e88324..81baa9011 100644 --- a/libguile/feature.h +++ b/libguile/feature.h @@ -2,7 +2,7 @@ #ifndef FEATUREH #define FEATUREH -/* Copyright (C) 1995, 1996, 1999 Free Software Foundation, Inc. +/* Copyright (C) 1995, 1996, 1999, 2000 Free Software Foundation, Inc. * * This program is free software; you can redistribute it and/or modify * it under the terms of the GNU General Public License as published by @@ -49,30 +49,9 @@ #include "libguile/__scm.h" -#define SCM_HOOKP(x) (SCM_NIMP(x) && (SCM_TYP16 (x) == scm_tc16_hook)) -#define SCM_HOOK_ARITY(hook) (SCM_UNPACK_CAR (hook) >> 16) -#define SCM_HOOK_NAME(hook) SCM_CADR (hook) -#define SCM_HOOK_PROCEDURES(hook) SCM_CDDR (hook) -#define SCM_SET_HOOK_PROCEDURES(hook, procs) SCM_SETCDR (SCM_CDR (hook), procs) - -extern long scm_tc16_hook; - extern void scm_add_feature (const char* str); extern SCM scm_program_arguments (void); extern void scm_set_program_arguments (int argc, char **argv, char *first); -extern SCM scm_make_hook (SCM n_args); -extern SCM scm_make_hook_with_name (SCM name, SCM n_args); -extern SCM scm_create_hook (const char* name, int n_args); -extern void scm_free_hook (SCM hook); -extern SCM scm_make_named_hook (const char* name, int n_args); -extern SCM scm_hook_p (SCM x); -extern SCM scm_hook_empty_p (SCM hook); -extern SCM scm_add_hook_x (SCM hook, SCM thunk, SCM appendp); -extern SCM scm_remove_hook_x (SCM hook, SCM thunk); -extern SCM scm_reset_hook_x (SCM hook); -extern SCM scm_run_hook (SCM hook, SCM args); -extern void scm_c_run_hook (SCM hook, SCM args); -extern SCM scm_hook_to_list (SCM hook); extern void scm_init_feature (void); #endif /* FEATUREH */ |