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 | ||
adaf86ec | 29 | SCM |
747022e4 | 30 | scm_c_make_prompt (SCM vm, SCM k, scm_t_uint8 escape_only_p) |
adaf86ec AW |
31 | { |
32 | scm_t_bits tag; | |
33 | SCM ret; | |
34 | struct scm_prompt_registers *regs; | |
35 | ||
36 | tag = scm_tc7_prompt; | |
adaf86ec AW |
37 | if (escape_only_p) |
38 | tag |= SCM_F_PROMPT_ESCAPE; | |
07a0c7d5 | 39 | ret = scm_words (tag, 5); |
adaf86ec AW |
40 | |
41 | regs = scm_gc_malloc_pointerless (sizeof (*regs), "prompt registers"); | |
42 | regs->fp = SCM_VM_DATA (vm)->fp; | |
43 | regs->sp = SCM_VM_DATA (vm)->sp; | |
44 | regs->ip = SCM_VM_DATA (vm)->ip; | |
45 | ||
46 | SCM_SET_CELL_OBJECT (ret, 1, k); | |
47 | SCM_SET_CELL_WORD (ret, 2, (scm_t_bits)regs); | |
48 | SCM_SET_CELL_OBJECT (ret, 3, scm_i_dynwinds ()); | |
adaf86ec AW |
49 | |
50 | return ret; | |
51 | } | |
52 | ||
eaefabee AW |
53 | SCM |
54 | scm_c_abort (SCM vm, SCM tag, size_t n, SCM *argv) | |
55 | { | |
56 | SCM winds, prompt = SCM_BOOL_F; | |
57 | long delta; | |
58 | size_t i; | |
59 | ||
60 | /* Search the wind list for an appropriate prompt. | |
61 | "Waiter, please bring us the wind list." */ | |
62 | for (winds = scm_i_dynwinds (), delta = 0; | |
63 | scm_is_pair (winds); | |
64 | winds = SCM_CDR (winds), delta++) | |
65 | { | |
66 | SCM elt = SCM_CAR (winds); | |
67 | if (SCM_PROMPT_P (elt) && scm_is_eq (SCM_PROMPT_TAG (elt), tag)) | |
68 | { | |
69 | prompt = elt; | |
70 | break; | |
71 | } | |
72 | } | |
73 | ||
74 | /* If we didn't find anything, print a message and abort the process | |
75 | right here. If you don't want this, establish a catch-all around | |
76 | any code that might throw up. */ | |
77 | if (scm_is_false (prompt)) | |
78 | { | |
79 | /* FIXME: jump to default */ | |
80 | /* scm_handle_by_message (NULL, key, args); */ | |
81 | abort (); | |
82 | } | |
83 | ||
84 | /* Unwind once more, beyond the prompt. */ | |
85 | winds = SCM_CDR (winds), delta++; | |
86 | ||
87 | /* Unwind */ | |
88 | scm_dowinds (winds, delta); | |
89 | ||
90 | /* Restore VM regs */ | |
91 | SCM_VM_DATA (vm)->fp = SCM_PROMPT_REGISTERS (prompt)->fp; | |
92 | SCM_VM_DATA (vm)->sp = SCM_PROMPT_REGISTERS (prompt)->sp; | |
93 | SCM_VM_DATA (vm)->ip = SCM_PROMPT_REGISTERS (prompt)->ip; | |
94 | ||
95 | /* Since we're jumping down, we should always have enough space */ | |
96 | if (SCM_VM_DATA (vm)->sp + n + 1 >= SCM_VM_DATA (vm)->stack_limit) | |
97 | abort (); | |
98 | ||
99 | /* Push vals */ | |
100 | *(++(SCM_VM_DATA (vm)->sp)) = SCM_BOOL_F; /* the continuation */ | |
101 | for (i = 0; i < n; i++) | |
102 | *(++(SCM_VM_DATA (vm)->sp)) = argv[i]; | |
103 | *(++(SCM_VM_DATA (vm)->sp)) = scm_from_size_t (n+1); /* +1 for continuation */ | |
104 | ||
105 | /* Jump! */ | |
106 | SCM_I_LONGJMP (SCM_PROMPT_REGISTERS (prompt)->regs, 1); | |
107 | ||
108 | /* Shouldn't get here */ | |
109 | abort (); | |
110 | } | |
adaf86ec | 111 | |
747022e4 AW |
112 | SCM_DEFINE (scm_abort, "abort", 1, 0, 1, (SCM tag, SCM args), |
113 | "Abort to the nearest prompt with tag @var{tag}.") | |
114 | #define FUNC_NAME s_scm_abort | |
b9c100d0 | 115 | { |
747022e4 AW |
116 | SCM *argv; |
117 | size_t i, n; | |
118 | ||
119 | SCM_VALIDATE_LIST_COPYLEN (SCM_ARG2, args, n); | |
120 | argv = alloca (sizeof (SCM)*n); | |
121 | for (i = 0; i < n; i++, args = scm_cdr (args)) | |
122 | argv[i] = scm_car (args); | |
123 | ||
124 | scm_c_abort (scm_the_vm (), tag, n, argv); | |
125 | ||
126 | /* Oh, what, you're still here? The abort must have been reinstated. OK, pull | |
127 | args back from the stack, and keep going... */ | |
128 | ||
129 | { | |
130 | SCM vals = SCM_EOL; | |
131 | struct scm_vm *vp = SCM_VM_DATA (scm_the_vm ()); | |
132 | n = scm_to_size_t (vp->sp[0]); | |
133 | for (i = 0; i < n; i++) | |
134 | vals = scm_cons (vp->sp[-(i + 1)], vals); | |
135 | /* The continuation call did reset the VM's registers, but then these values | |
136 | were pushed on; so we need to pop them ourselves. */ | |
137 | vp->sp -= n + 1; | |
138 | /* FIXME NULLSTACK */ | |
139 | ||
140 | return (scm_is_pair (vals) && scm_is_null (scm_cdr (vals))) | |
141 | ? scm_car (vals) : scm_values (vals); | |
142 | } | |
b9c100d0 | 143 | } |
747022e4 | 144 | #undef FUNC_NAME |
b9c100d0 | 145 | |
747022e4 | 146 | void scm_init_control (void) |
b9c100d0 | 147 | { |
747022e4 | 148 | #include "control.x" |
b9c100d0 AW |
149 | } |
150 | ||
151 | /* | |
152 | Local Variables: | |
153 | c-file-style: "gnu" | |
154 | End: | |
155 | */ |