Commit | Line | Data |
---|---|---|
b9c100d0 AW |
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" | |
adaf86ec | 25 | #include "libguile/vm.h" |
b9c100d0 AW |
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 | ||
adaf86ec | 51 | SCM |
ea6b18e8 | 52 | scm_c_make_prompt (SCM vm, SCM k, SCM handler, scm_t_uint8 escape_only_p) |
adaf86ec AW |
53 | { |
54 | scm_t_bits tag; | |
55 | SCM ret; | |
56 | struct scm_prompt_registers *regs; | |
57 | ||
58 | tag = scm_tc7_prompt; | |
adaf86ec AW |
59 | if (escape_only_p) |
60 | tag |= SCM_F_PROMPT_ESCAPE; | |
07a0c7d5 | 61 | ret = scm_words (tag, 5); |
adaf86ec AW |
62 | |
63 | regs = scm_gc_malloc_pointerless (sizeof (*regs), "prompt registers"); | |
64 | regs->fp = SCM_VM_DATA (vm)->fp; | |
65 | regs->sp = SCM_VM_DATA (vm)->sp; | |
66 | regs->ip = SCM_VM_DATA (vm)->ip; | |
67 | ||
68 | SCM_SET_CELL_OBJECT (ret, 1, k); | |
69 | SCM_SET_CELL_WORD (ret, 2, (scm_t_bits)regs); | |
70 | SCM_SET_CELL_OBJECT (ret, 3, scm_i_dynwinds ()); | |
71 | SCM_SET_CELL_OBJECT (ret, 4, handler); | |
adaf86ec AW |
72 | |
73 | return ret; | |
74 | } | |
75 | ||
eaefabee AW |
76 | SCM |
77 | scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv) | |
78 | { | |
79 | SCM winds, prompt = SCM_BOOL_F; | |
80 | long delta; | |
81 | size_t i; | |
82 | ||
83 | /* Search the wind list for an appropriate prompt. | |
84 | "Waiter, please bring us the wind list." */ | |
85 | for (winds = scm_i_dynwinds (), delta = 0; | |
86 | scm_is_pair (winds); | |
87 | winds = SCM_CDR (winds), delta++) | |
88 | { | |
89 | SCM elt = SCM_CAR (winds); | |
90 | if (SCM_PROMPT_P (elt) && scm_is_eq (SCM_PROMPT_TAG (elt), tag)) | |
91 | { | |
92 | prompt = elt; | |
93 | break; | |
94 | } | |
95 | } | |
96 | ||
97 | /* If we didn't find anything, print a message and abort the process | |
98 | right here. If you don't want this, establish a catch-all around | |
99 | any code that might throw up. */ | |
100 | if (scm_is_false (prompt)) | |
101 | { | |
102 | /* FIXME: jump to default */ | |
103 | /* scm_handle_by_message (NULL, key, args); */ | |
104 | abort (); | |
105 | } | |
106 | ||
107 | /* Unwind once more, beyond the prompt. */ | |
108 | winds = SCM_CDR (winds), delta++; | |
109 | ||
110 | /* Unwind */ | |
111 | scm_dowinds (winds, delta); | |
112 | ||
113 | /* Restore VM regs */ | |
114 | SCM_VM_DATA (vm)->fp = SCM_PROMPT_REGISTERS (prompt)->fp; | |
115 | SCM_VM_DATA (vm)->sp = SCM_PROMPT_REGISTERS (prompt)->sp; | |
116 | SCM_VM_DATA (vm)->ip = SCM_PROMPT_REGISTERS (prompt)->ip; | |
117 | ||
118 | /* Since we're jumping down, we should always have enough space */ | |
119 | if (SCM_VM_DATA (vm)->sp + n + 1 >= SCM_VM_DATA (vm)->stack_limit) | |
120 | abort (); | |
121 | ||
122 | /* Push vals */ | |
123 | *(++(SCM_VM_DATA (vm)->sp)) = SCM_BOOL_F; /* the continuation */ | |
124 | for (i = 0; i < n; i++) | |
125 | *(++(SCM_VM_DATA (vm)->sp)) = argv[i]; | |
126 | *(++(SCM_VM_DATA (vm)->sp)) = scm_from_size_t (n+1); /* +1 for continuation */ | |
127 | ||
128 | /* Jump! */ | |
129 | SCM_I_LONGJMP (SCM_PROMPT_REGISTERS (prompt)->regs, 1); | |
130 | ||
131 | /* Shouldn't get here */ | |
132 | abort (); | |
133 | } | |
adaf86ec | 134 | |
b9c100d0 AW |
135 | \f |
136 | ||
137 | static void | |
138 | scm_init_control (void) | |
139 | { | |
140 | #ifndef SCM_MAGIC_SNARFER | |
141 | #include "libguile/control.x" | |
142 | #endif | |
143 | } | |
144 | ||
145 | void | |
146 | scm_register_control (void) | |
147 | { | |
148 | scm_c_register_extension ("libguile", "scm_init_control", | |
149 | (scm_t_extension_init_func)scm_init_control, | |
150 | NULL); | |
151 | } | |
152 | ||
153 | /* | |
154 | Local Variables: | |
155 | c-file-style: "gnu" | |
156 | End: | |
157 | */ |