libguile/control.c

   1 /* Copyright (C) 2010  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 License
   5  * as published by the Free Software Foundation; either version 3 of
   6  * the License, or (at your option) any later version.
   7  *
   8  * This library is distributed in the hope that it will be useful, but
   9  * 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
  16  * 02110-1301 USA
  17  */
  18
  19 #if HAVE_CONFIG_H
  20 #  include <config.h>
  21 #endif
  22
  23 #include "libguile/_scm.h"
  24 #include "libguile/control.h"
  25 #include "libguile/vm.h"
  26
  27 \f
  28
  29 SCM scm_atcontrol (SCM, SCM, SCM);
  30 SCM_DEFINE (scm_atcontrol, "@control", 3, 0, 0,
  31             (SCM tag, SCM type, SCM args),
  32             "Transfer control to the handler of a delimited continuation.")
  33 #define FUNC_NAME s_scm_atcontrol
  34 {
  35   abort ();
  36   return SCM_UNSPECIFIED;
  37 }
  38 #undef FUNC_NAME
  39
  40 SCM scm_atprompt (SCM, SCM, SCM, SCM);
  41 SCM_DEFINE (scm_atprompt, "@prompt", 4, 0, 0,
  42             (SCM tag, SCM thunk, SCM handler, SCM pre_unwind_handler),
  43             "Begin a delimited continuation.")
  44 #define FUNC_NAME s_scm_atprompt
  45 {
  46   abort ();
  47   return SCM_UNSPECIFIED;
  48 }
  49 #undef FUNC_NAME
  50
  51 SCM
  52 scm_c_make_prompt (SCM vm, SCM k, SCM handler, scm_t_uint8 inline_handler_p,
  53                    scm_t_uint8 escape_only_p)
  54 {
  55   scm_t_bits tag;
  56   SCM ret;
  57   struct scm_prompt_registers *regs;
  58
  59   tag = scm_tc7_prompt;
  60   if (inline_handler_p)
  61     tag |= SCM_F_PROMPT_INLINE;
  62   if (escape_only_p)
  63     tag |= SCM_F_PROMPT_ESCAPE;
  64   ret = scm_words (tag, 5);
  65
  66   regs = scm_gc_malloc_pointerless (sizeof (*regs), "prompt registers");
  67   regs->fp = SCM_VM_DATA (vm)->fp;
  68   regs->sp = SCM_VM_DATA (vm)->sp;
  69   regs->ip = SCM_VM_DATA (vm)->ip;
  70
  71   SCM_SET_CELL_OBJECT (ret, 1, k);
  72   SCM_SET_CELL_WORD (ret, 2, (scm_t_bits)regs);
  73   SCM_SET_CELL_OBJECT (ret, 3, scm_i_dynwinds ());
  74   SCM_SET_CELL_OBJECT (ret, 4, handler);
  75
  76   return ret;
  77 }
  78
  79
  80 \f
  81
  82 static void
  83 scm_init_control (void)
  84 {
  85 #ifndef SCM_MAGIC_SNARFER
  86 #include "libguile/control.x"
  87 #endif
  88 }
  89
  90 void
  91 scm_register_control (void)
  92 {
  93   scm_c_register_extension ("libguile", "scm_init_control",
  94                             (scm_t_extension_init_func)scm_init_control,
  95                             NULL);
  96 }
  97
  98 /*
  99   Local Variables:
 100   c-file-style: "gnu"
 101   End:
 102 */