src/scwm_guile.c

   1 /*
   2  * scwm_guile.c
   3  * Copyright (C) 1999 Steve Tell
   4  *
   5  * based heavily on callbacks.c from SCWM:
   6  * Copyright (C) 1997-1999 Maciej Stachowiak and Greg J. Badros
   7  *
   8  * This program is free software; you can redistribute it and/or modify
   9  * it under the terms of the GNU General Public License as published by
  10  * the Free Software Foundation; either version 2, or (at your option)
  11  * any later version.
  12  *
  13  * This program is distributed in the hope that it will be useful,
  14  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  15  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  16  * GNU General Public License for more details.
  17  *
  18  * You should have received a copy of the GNU General Public License
  19  * along with this software; see the file COPYING.GPL.  If not, write to
  20  * the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  21  * Boston, MA 02111-1307 USA
  22  *
  23  */
  24
  25 #ifdef HAVE_CONFIG_H
  26 #include <config.h>
  27 #endif
  28
  29 #include <sys/time.h>
  30 #include <unistd.h>
  31 #include <limits.h>
  32 #include <assert.h>
  33
  34 #include <guile/gh.h>
  35 #include <libguile.h>
  36 #include <libguile/fluids.h>
  37
  38 #include "scwm_guile.h"
  39 #include "guile-compat.h"
  40
  41 #ifdef USE_DMALLOC
  42 #include "dmalloc.h"
  43 #endif
  44
  45 extern char *prog_name;
  46
  47 XSCM_HOOK(error_hook, "error-hook", 5, (SCM a, SCM b, SCM c, SCM d, SCM e),
  48 "Called on all kinds of errors and exceptions."
  49 "Whenever an error or other uncaught throw occurs on any callback,"
  50 "whether a hook, a mouse binding, a key binding, a menu entry, a file"
  51 "being processed, or anything else, error-hook will be invoked. Each"
  52 "procedure in the hook will be called with the throw arguments; these"
  53 "will generally include information about the nature of the error.");
  54
  55 struct scwm_body_apply_data {
  56   SCM proc;
  57   SCM args;
  58 };
  59
  60
  61 static SCM
  62 scwm_body_apply (void *body_data)
  63 {
  64   struct scwm_body_apply_data *ad = (struct scwm_body_apply_data *) body_data;
  65   return scm_apply(ad->proc, ad->args, SCM_EOL);
  66 }
  67
  68 /* Use scm_internal_cwdr to establish a new dynamic root - this causes
  69    all throws to be caught and prevents continuations from exiting the
  70    dynamic scope of the callback. This is needed to prevent callbacks
  71    from disrupting scwm's flow control, which would likely cause a
  72    crash. Use scm_internal_stack_catch to save the stack so we can
  73    display a backtrace. scm_internal_stack_cwdr is the combination of
  74    both. Note that the current implementation causes three(!) distinct
  75    catch-like constructs to be used; this may have negative, perhaps
  76    even significantly so, performance implications. */
  77
  78 struct cwssdr_data
  79 {
  80   SCM tag;
  81   scm_t_catch_body body;
  82   void *data;
  83   scm_t_catch_handler handler;
  84 };
  85
  86 static SCM
  87 cwssdr_body (void *data)
  88 {
  89   struct cwssdr_data *d = (struct cwssdr_data *) data;
  90   return scm_internal_stack_catch (d->tag, d->body, d->data, d->handler,
  91                                   NULL);
  92 }
  93
  94 SCM
  95 scm_internal_stack_cwdr (scm_t_catch_body body,
  96                          void *body_data,
  97                          scm_t_catch_handler handler,
  98                          void *handler_data,
  99                          SCM_STACKITEM *stack_item)
 100 {
 101   struct cwssdr_data d;
 102   d.tag = SCM_BOOL_T;
 103   d.body = body;
 104   d.data = body_data;
 105   d.handler = handler;
 106   return scm_internal_cwdr(cwssdr_body, &d, handler, handler_data,
 107                             stack_item);
 108 }
 109
 110
 111
 112 SCM
 113 scwm_safe_apply (SCM proc, SCM args)
 114 {
 115   SCM_STACKITEM stack_item;
 116   struct scwm_body_apply_data apply_data;
 117
 118   apply_data.proc = proc;
 119   apply_data.args = args;
 120
 121   return scm_internal_stack_cwdr(scwm_body_apply, &apply_data,
 122                                  scwm_handle_error, prog_name,
 123                                  &stack_item);
 124 }
 125
 126
 127 SCM
 128 scwm_safe_apply_message_only (SCM proc, SCM args)
 129 {
 130   SCM_STACKITEM stack_item;
 131   struct scwm_body_apply_data apply_data;
 132
 133   apply_data.proc = proc;
 134   apply_data.args = args;
 135
 136   return scm_internal_cwdr(scwm_body_apply, &apply_data,
 137                            scm_handle_by_message_noexit, prog_name,
 138                            &stack_item);
 139 }
 140
 141
 142 SCM
 143 scwm_safe_call0 (SCM thunk)
 144 {
 145   return scwm_safe_apply (thunk, SCM_EOL);
 146 }
 147
 148
 149 SCM
 150 scwm_safe_call1 (SCM proc, SCM arg)
 151 {
 152   /* This means w must cons (albeit only once) on each callback of
 153      size one - seems lame. */
 154   return scwm_safe_apply (proc, scm_list_1(arg));
 155 }
 156
 157
 158 SCM
 159 scwm_safe_call2 (SCM proc, SCM arg1, SCM arg2)
 160 {
 161   /* This means w must cons (albeit only once) on each callback of
 162      size two - seems lame. */
 163   return scwm_safe_apply (proc, scm_list_2(arg1, arg2));
 164 }
 165
 166 SCM
 167 scwm_safe_call3 (SCM proc, SCM arg1, SCM arg2, SCM arg3)
 168 {
 169   /* This means w must cons (albeit only once) on each callback of
 170      size two - seems lame. */
 171   return scwm_safe_apply (proc, scm_list_3(arg1, arg2, arg3));
 172 }
 173
 174 SCM
 175 scwm_safe_call4 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
 176 {
 177   /* This means w must cons (albeit only once) on each callback of
 178      size two - seems lame. */
 179   return scwm_safe_apply (proc, scm_list_4(arg1, arg2, arg3, arg4));
 180 }
 181
 182 SCM
 183 scwm_safe_call5 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5)
 184 {
 185   /* This means w must cons (albeit only once) on each callback of
 186      size two - seems lame. */
 187   return scwm_safe_apply (proc, scm_list_5(arg1, arg2, arg3, arg4, arg5));
 188 }
 189
 190 SCM
 191 scwm_safe_call6 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5, SCM arg6)
 192 {
 193   return scwm_safe_apply (proc, scm_list_n(arg1, arg2, arg3, arg4, arg5, arg6, SCM_UNDEFINED));
 194 }
 195
 196 SCM
 197 scwm_safe_call7 (SCM proc, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5, SCM arg6, SCM arg7)
 198 {
 199   return scwm_safe_apply (proc, scm_list_n(arg1, arg2, arg3, arg4, arg5, arg6, arg7, SCM_UNDEFINED));
 200 }
 201
 202
 203 static SCM run_hook_proc;
 204
 205 SCM scwm_run_hook(SCM hook, SCM args)
 206 {
 207
 208   return scwm_safe_apply(run_hook_proc, scm_cons(hook,args));
 209 }
 210
 211 SCM scwm_run_hook_message_only(SCM hook, SCM args)
 212 {
 213   return scwm_safe_apply_message_only(run_hook_proc, scm_cons(hook,args));
 214 }
 215
 216
 217 SCM call0_hooks(SCM hook)
 218 {
 219   return scwm_run_hook(hook,SCM_EOL);
 220 }
 221
 222 SCM call1_hooks(SCM hook, SCM arg1)
 223 {
 224   return scwm_run_hook(hook,scm_list_1(arg1));
 225 }
 226
 227 SCM call2_hooks(SCM hook, SCM arg1, SCM arg2)
 228 {
 229   return scwm_run_hook(hook,scm_list_2(arg1,arg2));
 230 }
 231
 232 SCM call3_hooks(SCM hook, SCM arg1, SCM arg2, SCM arg3)
 233 {
 234   return scwm_run_hook(hook,scm_list_n(arg1,arg2,arg3,SCM_UNDEFINED));
 235 }
 236
 237 SCM call4_hooks(SCM hook, SCM arg1, SCM arg2, SCM arg3, SCM arg4)
 238 {
 239   return scwm_run_hook(hook,scm_list_n(arg1,arg2,arg3,arg4,SCM_UNDEFINED));
 240 }
 241
 242 SCM call5_hooks(SCM hook, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5)
 243 {
 244   return scwm_run_hook(hook,scm_list_n(arg1,arg2,arg3,arg4,arg5,SCM_UNDEFINED));
 245 }
 246
 247 SCM call6_hooks(SCM hook, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5, SCM arg6)
 248 {
 249   return scwm_run_hook(hook,scm_list_n(arg1,arg2,arg3,arg4,arg5,arg6,SCM_UNDEFINED));
 250 }
 251
 252 SCM call7_hooks(SCM hook, SCM arg1, SCM arg2, SCM arg3, SCM arg4, SCM arg5, SCM arg6, SCM arg7)
 253 {
 254   return scwm_run_hook(hook,scm_list_n(arg1,arg2,arg3,arg4,arg5,arg6,arg7,SCM_UNDEFINED));
 255 }
 256
 257 SCM
 258 scm_empty_hook_p(SCM hook)
 259 {
 260   return scm_hook_empty_p(hook);
 261 }
 262
 263
 264 /* Slightly tricky - we want to catch errors per expression, but only
 265    establish a new dynamic root per load operation, as it's perfectly
 266    OK for a file to invoke a continuation created by a different
 267    expression in the file as far as scwm is concerned. So we set a
 268    dynamic root for the whole load operation, but also catch on each
 269    eval. */
 270
 271 static SCM
 272 scwm_body_eval_x (void *body_data)
 273 {
 274   SCM expr = *(SCM *) body_data;
 275   return scm_eval_x (expr, scm_current_module() );
 276 }
 277
 278 static SCM
 279 scwm_catching_eval_x (SCM expr) {
 280   return scm_internal_stack_catch (SCM_BOOL_T, scwm_body_eval_x, &expr,
 281                           scwm_handle_error, prog_name);
 282 }
 283
 284 static SCM
 285 scwm_catching_load_from_port (SCM port)
 286 {
 287   SCM expr;
 288   SCM answer = SCM_UNSPECIFIED;
 289
 290   while (!SCM_EOF_OBJECT_P(expr = scm_read (port))) {
 291     answer = scwm_catching_eval_x (expr);
 292   }
 293   scm_close_port (port);
 294
 295   return answer;
 296 }
 297
 298 static SCM
 299 scwm_body_load (void *body_data)
 300 {
 301   SCM filename = *(SCM *) body_data;
 302   SCM port = scm_open_file (filename, scm_makfrom0str("r"));
 303   return scwm_catching_load_from_port (port);
 304 }
 305
 306 static SCM
 307 scwm_body_eval_str (void *body_data)
 308 {
 309   char *string = (char *) body_data;
 310   SCM port = scm_mkstrport (SCM_MAKINUM (0), scm_makfrom0str(string),
 311                             SCM_OPN | SCM_RDNG, "scwm_safe_eval_str");
 312   return scwm_catching_load_from_port (port);
 313 }
 314
 315
 316 SCM
 317 scwm_handle_error (void *ARG_IGNORE(data), SCM tag, SCM throw_args)
 318 {
 319 #if 0 /* GJB:FIXME:: */
 320   SCM port = scm_mkstrport(SCM_INUM0,
 321                            scm_make_string(SCM_MAKINUM(200), SCM_UNDEFINED),
 322                            SCM_OPN | SCM_WRTNG,
 323                            "error-handler");
 324 #else
 325   SCM port =  scm_current_error_port();
 326 #endif
 327
 328   /* GJB:FIXME:MS: is this a guile compatibility test that can be dropped
 329      now?  */
 330   if (scm_ilength (throw_args) >= 3)
 331     {
 332       SCM fl;
 333       fl = SCM_VARIABLE_REF (scm_the_last_stack_fluid_var);
 334
 335       /* GJB:FIXME:MS: This is a horrible hack,
 336          but DEREF_LAST_STACK macro was throwing a wrong type
 337          argument at weird times, and I'm trying to avoid
 338          a crash when I demo to RMS tomorrow, hence this
 339          ugly hack --04/27/99 gjb */
 340       if (SCM_NIMP (fl) && SCM_FLUIDP (fl)) {
 341         SCM stack = DEREF_LAST_STACK;
 342         SCM subr = SCM_CAR (throw_args);
 343         SCM message = SCM_CADR (throw_args);
 344         SCM args = SCM_CADDR (throw_args);
 345
 346         scm_newline(port);
 347         scm_display_backtrace (stack, port, SCM_UNDEFINED, SCM_UNDEFINED);
 348         scm_newline(port);
 349         scm_display_error (stack, port, subr, message, args, SCM_EOL);
 350       } else {
 351 /*        scwm_msg(ERR,"scwm_handle_error","scm_the_last_stack_fluid not holding a fluid!"); */
 352       }
 353     }
 354   else
 355     {
 356       scm_puts ("uncaught throw to ", port);
 357       scm_prin1 (tag, port, 0);
 358       scm_puts (": ", port);
 359       scm_prin1 (throw_args, port, 1);
 360       scm_putc ('\n', port);
 361       exit (2);
 362     }
 363   /* GJB:FIXME:MS: can the scheme code display a backtrace without the
 364      stack argument? */
 365   return scwm_run_hook_message_only(error_hook, scm_cons(tag, throw_args));
 366 }
 367
 368
 369 SCM_DEFINE(safe_load, "safe-load", 1, 0, 0,
 370            (SCM fname),
 371 "Load file FNAME while trapping and displaying errors."
 372 "Each individual top-level-expression is evaluated separately and all"
 373 "errors are trapped and displayed.  You should use this procedure if"
 374 "you need to make sure most of a file loads, even if it may contain"
 375 "errors.")
 376 #define FUNC_NAME s_safe_load
 377 {
 378   SCM_STACKITEM stack_item;
 379   VALIDATE_ARG_STR(1,fname);
 380   return scm_internal_cwdr(scwm_body_load, &fname,
 381                                      scm_handle_by_message_noexit, prog_name,
 382                                      &stack_item);
 383 }
 384 #undef FUNC_NAME
 385
 386 SCM scwm_safe_load (char *filename)
 387 {
 388   return safe_load(scm_makfrom0str(filename));
 389 }
 390
 391 SCM scwm_safe_eval_str (char *string)
 392 {
 393   SCM_STACKITEM stack_item;
 394   return scm_internal_cwdr(scwm_body_eval_str, string,
 395                                      scm_handle_by_message_noexit, prog_name,
 396                                      &stack_item);
 397 }
 398
 399 void init_scwm_guile()
 400 {
 401   run_hook_proc = gh_lookup("run-hook");
 402
 403 #ifndef SCM_MAGIC_SNARF_INITS
 404 #include "scwm_guile.x"
 405 #endif
 406 }
 407
 408 \f
 409 /* Local Variables: */
 410 /* tab-width: 8 */
 411 /* c-basic-offset: 2 */
 412 /* End: */
 413 /* vim:ts=8:sw=2:sta
 414  */
 415