1 /* Copyright (C) 1995,1996,1998 Free Software Foundation, Inc.
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)
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.
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
18 * As a special exception, the Free Software Foundation gives permission
19 * for additional uses of the text contained in its release of GUILE.
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.
27 * This exception does not however invalidate any other reasons why
28 * the executable file might be covered by the GNU General Public License.
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.
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. */
56 static SCM
*scm_loc_features
;
62 *scm_loc_features
= scm_cons (SCM_CAR (scm_intern (str
, strlen (str
))),
68 SCM_PROC(s_program_arguments
, "program-arguments", 0, 0, 0, scm_program_arguments
);
71 scm_program_arguments ()
76 /* Set the value returned by program-arguments, given ARGC and ARGV.
78 If FIRST is non-zero, make it the first element; we do this in
79 situations where other code (like getopt) has parsed out a few
80 arguments, but we still want the script name to be the first
83 scm_set_program_arguments (argc
, argv
, first
)
88 scm_progargs
= scm_makfromstrs (argc
, argv
);
90 scm_progargs
= scm_cons (scm_makfrom0str (first
), scm_progargs
);
97 SCM_SYMBOL (scm_sym_hook
, "hook");
99 SCM_PROC (s_make_hook
, "make-hook", 0, 1, 0, scm_make_hook
);
102 scm_make_hook (SCM n_args
)
104 if (SCM_UNBNDP (n_args
))
107 SCM_ASSERT (SCM_INUMP (n_args
), n_args
, SCM_ARG1
, s_make_hook
);
108 return scm_cons2 (scm_sym_hook
, n_args
, SCM_EOL
);
112 scm_make_named_hook (char* name
, int n_args
)
114 SCM hook
= scm_make_hook (SCM_MAKINUM (n_args
));
115 scm_permanent_object (scm_sysintern (name
, hook
));
119 SCM_PROC (s_add_hook_x
, "add-hook!", 2, 1, 0, scm_add_hook_x
);
122 scm_add_hook_x (SCM hook
, SCM proc
, SCM append_p
)
126 SCM_ASSERT (SCM_NIMP (hook
) && SCM_CONSP (hook
)
127 && SCM_CAR (hook
) == scm_sym_hook
128 && SCM_NIMP (SCM_CDR (hook
)) && SCM_CONSP (SCM_CDR (hook
))
129 && SCM_INUMP (SCM_CADR (hook
))
130 && scm_ilength (SCM_CDDR (hook
)) >= 0,
131 hook
, SCM_ARG1
, s_add_hook_x
);
132 SCM_ASSERT (SCM_NFALSEP (arity
= scm_i_procedure_arity (proc
)),
133 proc
, SCM_ARG2
, s_add_hook_x
);
134 n_args
= SCM_INUM (SCM_CADR (hook
));
135 if (SCM_INUM (SCM_CAR (arity
)) > n_args
136 || (SCM_FALSEP (SCM_CADDR (arity
))
137 && (SCM_INUM (SCM_CAR (arity
)) + SCM_INUM (SCM_CADR (arity
))
139 scm_misc_error (s_add_hook_x
,
140 "This hook requires %s arguments",
141 SCM_LIST1 (SCM_CADR (hook
)));
142 rest
= scm_delq_x (proc
, SCM_CDDR (hook
));
143 SCM_SETCDR (SCM_CDR (hook
),
144 (!SCM_UNBNDP (append_p
) && SCM_NFALSEP (append_p
)
145 ? scm_append_x (SCM_LIST2 (rest
, SCM_LIST1 (proc
)))
146 : scm_cons (proc
, rest
)));
147 return SCM_UNSPECIFIED
;
150 SCM_PROC (s_remove_hook_x
, "remove-hook!", 2, 0, 0, scm_remove_hook_x
);
153 scm_remove_hook_x (SCM hook
, SCM thunk
)
155 SCM_ASSERT (SCM_NIMP (hook
) && SCM_CONSP (hook
)
156 && SCM_CAR (hook
) == scm_sym_hook
157 && SCM_NIMP (SCM_CDR (hook
)) && SCM_CONSP (SCM_CDR (hook
))
158 && SCM_INUMP (SCM_CADR (hook
))
159 && scm_ilength (SCM_CDDR (hook
)) >= 0,
160 hook
, SCM_ARG1
, s_remove_hook_x
);
161 SCM_SETCDR (SCM_CDR (hook
), scm_delq_x (thunk
, SCM_CDDR (hook
)));
162 return SCM_UNSPECIFIED
;
165 SCM_PROC (s_reset_hook_x
, "reset-hook!", 1, 0, 0, scm_reset_hook_x
);
168 scm_reset_hook_x (SCM hook
)
170 SCM_ASSERT (SCM_NIMP (hook
) && SCM_CONSP (hook
)
171 && SCM_CAR (hook
) == scm_sym_hook
172 && SCM_NIMP (SCM_CDR (hook
)) && SCM_CONSP (SCM_CDR (hook
))
173 && SCM_INUMP (SCM_CADR (hook
))
174 && scm_ilength (SCM_CDDR (hook
)) >= 0,
175 hook
, SCM_ARG1
, s_reset_hook_x
);
176 SCM_SETCDR (SCM_CDR (hook
), SCM_EOL
);
177 return SCM_UNSPECIFIED
;
180 SCM_PROC (s_run_hook
, "run-hook", 1, 0, 1, scm_run_hook
);
183 scm_run_hook (SCM hook
, SCM args
)
185 SCM_ASSERT (SCM_NIMP (hook
) && SCM_CONSP (hook
)
186 && SCM_CAR (hook
) == scm_sym_hook
187 && SCM_NIMP (SCM_CDR (hook
)) && SCM_CONSP (SCM_CDR (hook
))
188 && SCM_INUMP (SCM_CADR (hook
))
189 && scm_ilength (SCM_CDDR (hook
)) >= 0,
190 hook
, SCM_ARG1
, s_run_hook
);
191 if (SCM_UNBNDP (args
))
193 if (scm_ilength (args
) != SCM_INUM (SCM_CADR (hook
)))
194 scm_misc_error (s_add_hook_x
,
195 "This hook requires %s arguments",
196 SCM_LIST1 (SCM_CADR (hook
)));
197 hook
= SCM_CDR (hook
);
198 while (SCM_NIMP (hook
= SCM_CDR (hook
)))
199 scm_apply (SCM_CAR (hook
), args
, SCM_EOL
);
200 return SCM_UNSPECIFIED
;
208 scm_loc_features
= SCM_CDRLOC (scm_sysintern ("*features*", SCM_EOL
));
210 scm_add_feature("reckless");
213 scm_add_feature("system");
216 scm_add_feature(s_ed
);
219 scm_add_feature("sicp");
222 scm_add_feature("char-ready?");
224 #ifndef CHEAP_CONTINUATIONS
225 scm_add_feature ("full-continuation");
228 scm_add_feature ("threads");
231 scm_sysintern ("char-code-limit", SCM_MAKINUM (SCM_CHAR_CODE_LIMIT
));