libguile/feature.c

   1 /*      Copyright (C) 1995,1996,1998 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 \f
  42
  43 #include <stdio.h>
  44 #include "_scm.h"
  45
  46 #include "eval.h"
  47 #include "procprop.h"
  48 #include "smob.h"
  49
  50 #include "feature.h"
  51
  52 #ifdef HAVE_STRING_H
  53 #include <string.h>
  54 #endif
  55 \f
  56
  57 static SCM *scm_loc_features;
  58
  59 void
  60 scm_add_feature (str)
  61      const char* str;
  62 {
  63   *scm_loc_features = scm_cons (SCM_CAR (scm_intern (str, strlen (str))),
  64                                 *scm_loc_features);
  65 }
  66
  67
  68 \f
  69 SCM_PROC(s_program_arguments, "program-arguments", 0, 0, 0, scm_program_arguments);
  70
  71 SCM
  72 scm_program_arguments ()
  73 {
  74   return scm_progargs;
  75 }
  76
  77 /* Set the value returned by program-arguments, given ARGC and ARGV.
  78
  79    If FIRST is non-zero, make it the first element; we do this in
  80    situations where other code (like getopt) has parsed out a few
  81    arguments, but we still want the script name to be the first
  82    element.  */
  83 void
  84 scm_set_program_arguments (argc, argv, first)
  85      int argc;
  86      char **argv;
  87      char *first;
  88 {
  89   scm_progargs = scm_makfromstrs (argc, argv);
  90   if (first)
  91     scm_progargs = scm_cons (scm_makfrom0str (first), scm_progargs);
  92 }
  93
  94
  95 \f
  96 /* Hooks */
  97
  98 long scm_tc16_hook;
  99
 100
 101 SCM_PROC (s_make_hook, "make-hook", 0, 1, 0, scm_make_hook);
 102
 103 SCM
 104 scm_make_hook (SCM n_args)
 105 {
 106   int n;
 107   if (SCM_UNBNDP (n_args))
 108     n = 0;
 109   else
 110     {
 111       SCM_ASSERT (SCM_INUMP (n_args), n_args, SCM_ARG1, s_make_hook);
 112       n = SCM_INUM (n_args);
 113     }
 114   SCM_ASSERT (n >= 0 && n <= 16, n_args, SCM_OUTOFRANGE, s_make_hook);
 115   SCM_RETURN_NEWSMOB (scm_tc16_hook + (n << 16), SCM_EOL);
 116 }
 117
 118
 119 SCM
 120 scm_make_named_hook (char* name, int n_args)
 121 {
 122   SCM hook = scm_make_hook (SCM_MAKINUM (n_args));
 123   scm_permanent_object (scm_sysintern (name, hook));
 124   return hook;
 125 }
 126
 127
 128 SCM_PROC (s_hook_p, "hook?", 1, 0, 0, scm_hook_p);
 129
 130 SCM
 131 scm_hook_p (SCM x)
 132 {
 133   return SCM_NIMP (x) && SCM_HOOKP (x) ? SCM_BOOL_T : SCM_BOOL_F;
 134 }
 135
 136
 137 SCM_PROC (s_hook_empty_p, "hook-empty?", 1, 0, 0, scm_hook_empty_p);
 138
 139 SCM
 140 scm_hook_empty_p (SCM hook)
 141 {
 142   SCM_ASSERT (SCM_NIMP (hook) && SCM_HOOKP (hook),
 143               hook, SCM_ARG1, s_hook_empty_p);
 144   return SCM_NULLP (SCM_HOOK_PROCEDURES (hook)) ? SCM_BOOL_T : SCM_BOOL_F;
 145 }
 146
 147
 148 SCM_PROC (s_add_hook_x, "add-hook!", 2, 1, 0, scm_add_hook_x);
 149
 150 SCM
 151 scm_add_hook_x (SCM hook, SCM proc, SCM append_p)
 152 {
 153   SCM arity, rest;
 154   int n_args;
 155   SCM_ASSERT (SCM_NIMP (hook) && SCM_HOOKP (hook),
 156               hook, SCM_ARG1, s_add_hook_x);
 157   SCM_ASSERT (SCM_NFALSEP (arity = scm_i_procedure_arity (proc)),
 158               proc, SCM_ARG2, s_add_hook_x);
 159   n_args = SCM_HOOK_ARITY (hook);
 160   if (SCM_INUM (SCM_CAR (arity)) > n_args
 161       || (SCM_FALSEP (SCM_CADDR (arity))
 162           && (SCM_INUM (SCM_CAR (arity)) + SCM_INUM (SCM_CADR (arity))
 163               < n_args)))
 164     scm_misc_error (s_add_hook_x,
 165                     "This hook requires %s arguments",
 166                     SCM_LIST1 (SCM_MAKINUM (SCM_HOOK_ARITY (hook))));
 167   rest = scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook));
 168   SCM_SET_HOOK_PROCEDURES (hook,
 169                            (!SCM_UNBNDP (append_p) && SCM_NFALSEP (append_p)
 170                             ? scm_append_x (SCM_LIST2 (rest, SCM_LIST1 (proc)))
 171                             : scm_cons (proc, rest)));
 172   return SCM_UNSPECIFIED;
 173 }
 174
 175
 176 SCM_PROC (s_remove_hook_x, "remove-hook!", 2, 0, 0, scm_remove_hook_x);
 177
 178 SCM
 179 scm_remove_hook_x (SCM hook, SCM proc)
 180 {
 181   SCM_ASSERT (SCM_NIMP (hook) && SCM_HOOKP (hook),
 182               hook, SCM_ARG1, s_remove_hook_x);
 183   SCM_SET_HOOK_PROCEDURES (hook,
 184                            scm_delq_x (proc, SCM_HOOK_PROCEDURES (hook)));
 185   return SCM_UNSPECIFIED;
 186 }
 187
 188
 189 SCM_PROC (s_reset_hook_x, "reset-hook!", 1, 0, 0, scm_reset_hook_x);
 190
 191 SCM
 192 scm_reset_hook_x (SCM hook)
 193 {
 194   SCM_ASSERT (SCM_NIMP (hook) && SCM_HOOKP (hook),
 195               hook, SCM_ARG1, s_reset_hook_x);
 196   SCM_SET_HOOK_PROCEDURES (hook, SCM_EOL);
 197   return SCM_UNSPECIFIED;
 198 }
 199
 200
 201 SCM_PROC (s_run_hook, "run-hook", 1, 0, 1, scm_run_hook);
 202
 203 SCM
 204 scm_run_hook (SCM hook, SCM args)
 205 {
 206   SCM_ASSERT (SCM_NIMP (hook) && SCM_HOOKP (hook),
 207               hook, SCM_ARG1, s_run_hook);
 208   if (SCM_UNBNDP (args))
 209     args = SCM_EOL;
 210   if (scm_ilength (args) != SCM_HOOK_ARITY (hook))
 211     scm_misc_error (s_add_hook_x,
 212                     "This hook requires %s arguments",
 213                     SCM_LIST1 (SCM_MAKINUM (SCM_HOOK_ARITY (hook))));
 214   scm_c_run_hook (hook, args);
 215   return SCM_UNSPECIFIED;
 216 }
 217
 218
 219 void
 220 scm_c_run_hook (SCM hook, SCM args)
 221 {
 222   SCM procs = SCM_HOOK_PROCEDURES (hook);
 223   while (SCM_NIMP (procs))
 224     {
 225       scm_apply (SCM_CAR (procs), args, SCM_EOL);
 226       procs = SCM_CDR (procs);
 227     }
 228 }
 229
 230
 231 SCM_PROC (s_hook_to_list, "hook->list", 1, 0, 0, scm_hook_to_list);
 232
 233 SCM
 234 scm_hook_to_list (SCM hook)
 235 {
 236   SCM_ASSERT (SCM_NIMP (hook) && SCM_HOOKP (hook),
 237               hook, SCM_ARG1, s_hook_to_list);
 238   return scm_list_copy (SCM_HOOK_PROCEDURES (hook));
 239 }
 240
 241
 242 \f
 243
 244 void
 245 scm_init_feature()
 246 {
 247   scm_loc_features = SCM_CDRLOC (scm_sysintern ("*features*", SCM_EOL));
 248 #ifdef SCM_RECKLESS
 249   scm_add_feature("reckless");
 250 #endif
 251 #ifndef _Windows
 252   scm_add_feature("system");
 253 #endif
 254 #ifdef vms
 255   scm_add_feature(s_ed);
 256 #endif
 257 #ifdef SICP
 258   scm_add_feature("sicp");
 259 #endif
 260 #ifndef GO32
 261   scm_add_feature("char-ready?");
 262 #endif
 263 #ifndef CHEAP_CONTINUATIONS
 264   scm_add_feature ("full-continuation");
 265 #endif
 266 #ifdef USE_THREADS
 267   scm_add_feature ("threads");
 268 #endif
 269
 270   scm_sysintern ("char-code-limit", SCM_MAKINUM (SCM_CHAR_CODE_LIMIT));
 271
 272   scm_tc16_hook = scm_make_smob_type ("hook", 0);
 273   scm_set_smob_mark (scm_tc16_hook, scm_markcdr);
 274
 275 #include "feature.x"
 276 }