1 /* Copyright (C) 2010 Free Software Foundation, Inc.
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.
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.
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
23 #include "libguile/_scm.h"
24 #include "libguile/control.h"
25 #include "libguile/vm.h"
30 scm_c_make_prompt (SCM vm
, SCM k
, scm_t_uint8 escape_only_p
)
34 struct scm_prompt_registers
*regs
;
38 tag
|= SCM_F_PROMPT_ESCAPE
;
39 ret
= scm_words (tag
, 5);
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
;
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 ());
54 scm_c_abort (SCM vm
, SCM tag
, size_t n
, SCM
*argv
)
56 SCM winds
, prompt
= SCM_BOOL_F
;
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;
64 winds
= SCM_CDR (winds
), delta
++)
66 SCM elt
= SCM_CAR (winds
);
67 if (SCM_PROMPT_P (elt
) && scm_is_eq (SCM_PROMPT_TAG (elt
), tag
))
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
))
79 /* FIXME: jump to default */
80 /* scm_handle_by_message (NULL, key, args); */
84 /* Unwind once more, beyond the prompt. */
85 winds
= SCM_CDR (winds
), delta
++;
88 scm_dowinds (winds
, delta
);
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
;
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
)
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 */
106 SCM_I_LONGJMP (SCM_PROMPT_REGISTERS (prompt
)->regs
, 1);
108 /* Shouldn't get here */
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
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
);
124 scm_c_abort (scm_the_vm (), tag
, n
, argv
);
126 /* Oh, what, you're still here? The abort must have been reinstated. OK, pull
127 args back from the stack, and keep going... */
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. */
138 /* FIXME NULLSTACK */
140 return (scm_is_pair (vals
) && scm_is_null (scm_cdr (vals
)))
141 ? scm_car (vals
) : scm_values (vals
);
146 void scm_init_control (void)