← Back to branch summary

~ubuntu-branches/ubuntu/hardy/sigscheme/hardy-proposed

« back to all changes in this revision

Viewing changes to operations-srfi34.c

  • Committer: Bazaar Package Importer
  • Author(s): NIIBE Yutaka
  • Date: 2006-05-23 21:46:41 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20060523214641-6ix4gz34wpiehub8
Tags: 0.5.0-2
http://bugs.debian.org/368571
* debian/control (Build-Depends): Added ruby.
  Thanks to Frederik Schueler.  Closes: #368571
* debian/rules (clean): invoke 'distclean' instead of 'clean'.

Show diffs side-by-side

added added

removed removed

Lines of Context:
operations-srfi34.c
1
 
/*===========================================================================
2
 
 *  FileName : operations-srfi34.c
3
 
 *  About    : Exception Handling for Programs
4
 
 *
5
 
 *  Copyright (C) 2005      by Kazuki Ohta (mover@hct.zaq.ne.jp)
6
 
 *
7
 
 *  All rights reserved.
8
 
 *
9
 
 *  Redistribution and use in source and binary forms, with or without
10
 
 *  modification, are permitted provided that the following conditions
11
 
 *  are met:
12
 
 *
13
 
 *  1. Redistributions of source code must retain the above copyright
14
 
 *     notice, this list of conditions and the following disclaimer.
15
 
 *  2. Redistributions in binary form must reproduce the above copyright
16
 
 *     notice, this list of conditions and the following disclaimer in the
17
 
 *     documentation and/or other materials provided with the distribution.
18
 
 *  3. Neither the name of authors nor the names of its contributors
19
 
 *     may be used to endorse or promote products derived from this software
20
 
 *     without specific prior written permission.
21
 
 *
22
 
 *  THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ``AS IS''
23
 
 *  AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
24
 
 *  IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
25
 
 *  ARE DISCLAIMED.  IN NO EVENT SHALL THE COPYRIGHT HOLDERS OR CONTRIBUTORS BE
26
 
 *  LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
27
 
 *  CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE
28
 
 *  GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)
29
 
 *  HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
30
 
 *  LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY
31
 
 *  OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF
32
 
 *  SUCH DAMAGE.
33
 
===========================================================================*/
34
 
 
35
 
/*=======================================
36
 
  System Include
37
 
=======================================*/
38
 
#include <setjmp.h>
39
 
 
40
 
/*=======================================
41
 
  Local Include
42
 
=======================================*/
43
 
#include "sigscheme.h"
44
 
#include "sigschemeinternal.h"
45
 
 
46
 
/*=======================================
47
 
  File Local Struct Declarations
48
 
=======================================*/
49
 
 
50
 
/*=======================================
51
 
  File Local Macro Declarations
52
 
=======================================*/
53
 
#define CONTINUATION_JMPENV     SCM_CONTINUATION_OPAQUE0
54
 
#define CONTINUATION_SET_JMPENV SCM_CONTINUATION_SET_OPAQUE0
55
 
 
56
 
/*=======================================
57
 
  Variable Declarations
58
 
=======================================*/
59
 
ScmObj scm_exception_handlers      = NULL;
60
 
ScmObj scm_exception_continuations = NULL;
61
 
 
62
 
static ScmObj exception_thrown_obj = NULL;
63
 
 
64
 
/*=======================================
65
 
  File Local Function Declarations
66
 
=======================================*/
67
 
static ScmObj guard_handle_clauses(ScmObj clauses, ScmObj env);
68
 
 
69
 
/*=======================================
70
 
  Function Implementations
71
 
=======================================*/
72
 
void SigScm_Initialize_SRFI34(void)
73
 
{
74
 
    /*=======================================================================
75
 
      SRFI-34 Procedure
76
 
    =======================================================================*/
77
 
    Scm_RegisterProcedureFixed2("with-exception-handler", ScmOp_SRFI34_with_exception_handler);
78
 
    Scm_RegisterSyntaxVariadic1("guard"                 , ScmExp_SRFI34_guard);
79
 
    Scm_RegisterProcedureFixed1("raise"                 , ScmOp_SRFI34_raise);
80
 
    scm_exception_handlers      = SCM_FALSE;
81
 
    scm_exception_continuations = SCM_FALSE;
82
 
    SigScm_GC_Protect(&scm_exception_handlers);
83
 
    SigScm_GC_Protect(&scm_exception_continuations);
84
 
}
85
 
 
86
 
/*
87
 
 * FIXME: Reimplement with dynamic-wind as "Reference Implementation" of
88
 
 * SRFI-34 does, without direct use of setjmp/longjmp
89
 
 */
90
 
ScmObj ScmOp_SRFI34_with_exception_handler(ScmObj handler, ScmObj thunk)
91
 
{
92
 
    jmp_buf jmpenv;
93
 
    ScmObj ret  = SCM_FALSE;
94
 
    ScmObj cont = Scm_NewContinuation();
95
 
    DECLARE_FUNCTION("with-exception-handler", ProcedureFixed2);
96
 
 
97
 
    ASSERT_PROCEDUREP(handler);
98
 
    ASSERT_PROCEDUREP(thunk);
99
 
 
100
 
    CONTINUATION_SET_JMPENV(cont, &jmpenv);
101
 
    if (setjmp(CONTINUATION_JMPENV(cont))) {
102
 
        ret = Scm_call(CURRENT_EXCEPTION_HANDLER(), LIST_1(exception_thrown_obj));
103
 
        POP_EXCEPTION_CONTINUATION();
104
 
        POP_EXCEPTION_HANDLER();
105
 
        exception_thrown_obj = SCM_FALSE; /* make sweepable */
106
 
        return ret;
107
 
    }
108
 
 
109
 
    PUSH_EXCEPTION_HANDLER(handler);
110
 
    PUSH_EXCEPTION_CONTINUATION(cont);
111
 
    ret = Scm_call(thunk, SCM_NULL);
112
 
    POP_EXCEPTION_CONTINUATION();
113
 
    POP_EXCEPTION_HANDLER();
114
 
 
115
 
    return ret;
116
 
}
117
 
 
118
 
/*
119
 
 * FIXME: Reimplement with dynamic-wind, Scm_CallWithCurrentContinuation() and
120
 
 * Scm_CallContinuation() as "Reference Implementation" of SRFI-34 does,
121
 
 * without direct use of setjmp/longjmp
122
 
 */
123
 
ScmObj ScmExp_SRFI34_guard(ScmObj var_and_clauses, ScmObj body, ScmObj env)
124
 
{
125
 
    /* (guard (var clauses) body) */
126
 
    jmp_buf jmpenv;
127
 
    ScmObj var     = SCM_FALSE;
128
 
    ScmObj clauses = SCM_FALSE;
129
 
    ScmObj expr    = SCM_FALSE;
130
 
    ScmObj cont    = Scm_NewContinuation();
131
 
    DECLARE_FUNCTION("guard", SyntaxVariadic1);
132
 
 
133
 
    ASSERT_CONSP(var_and_clauses);
134
 
 
135
 
    var     = CAR(var_and_clauses);
136
 
    clauses = CDR(var_and_clauses);
137
 
 
138
 
    ASSERT_SYMBOLP(var);
139
 
 
140
 
    /* check if return from "raise" */
141
 
    CONTINUATION_SET_JMPENV(cont, &jmpenv);
142
 
    if (setjmp(CONTINUATION_JMPENV(cont))) {
143
 
        POP_EXCEPTION_CONTINUATION();
144
 
        env = Scm_ExtendEnvironment(LIST_1(var), LIST_1(exception_thrown_obj), env);
145
 
        return guard_handle_clauses(clauses, env);
146
 
    }
147
 
 
148
 
    PUSH_EXCEPTION_CONTINUATION(cont);
149
 
    while (!NO_MORE_ARG(body)) {
150
 
        expr = POP_ARG(body);
151
 
        expr = EVAL(expr, env);
152
 
    }
153
 
    POP_EXCEPTION_CONTINUATION();
154
 
 
155
 
    return expr;
156
 
}
157
 
 
158
 
/* FIXME:
159
 
 * - Simplify with ScmExp_cond()
160
 
 */
161
 
static ScmObj guard_handle_clauses(ScmObj clauses, ScmObj env)
162
 
{
163
 
    ScmObj thrown  = exception_thrown_obj;
164
 
    ScmObj clause  = SCM_FALSE;
165
 
    ScmObj test    = SCM_FALSE;
166
 
    ScmObj exps    = SCM_FALSE;
167
 
    ScmObj proc    = SCM_FALSE;
168
 
    ScmObj ret     = SCM_FALSE;
169
 
    DECLARE_INTERNAL_FUNCTION("guard");
170
 
 
171
 
    /* make sweepable */
172
 
    exception_thrown_obj = SCM_FALSE;
173
 
 
174
 
    /* handle "cond" like clause */
175
 
    for (; !NULLP(clauses); clauses = CDR(clauses)) {
176
 
        clause = CAR(clauses);
177
 
        if (!CONSP(clause))
178
 
            ERR_OBJ("bad clause ", clause);
179
 
 
180
 
        test = CAR(clause);
181
 
        exps = CDR(clause);
182
 
 
183
 
        /* evaluate test */
184
 
        test = EVAL(test, env);
185
 
 
186
 
        if (NFALSEP(test)) {
187
 
            /*
188
 
             * if the selected <clause> contains only the <test> and no <expression>s,
189
 
             * then the value of the <test> is returned as the result.
190
 
             */
191
 
            if (NULLP(exps))
192
 
                return test;
193
 
 
194
 
            /*
195
 
             * If the selected <clause> uses the => alternate form, then the <expression>
196
 
             * is evaluated. Its value must be a procedure that accepts one argument;
197
 
             * this procedure is then called on the value of the <test> and the value
198
 
             * returned by this procedure is returned by the guard expression.
199
 
             */
200
 
            /* FIXME: remove expensive Scm_Intern() */
201
 
            if (EQ(Scm_Intern("=>"), CAR(exps))) {
202
 
                proc = EVAL(CADR(exps), env);
203
 
                if (FALSEP(ScmOp_procedurep(proc)))
204
 
                    ERR_OBJ("the value of exp after => must be the procedure but got ", proc);
205
 
 
206
 
                return Scm_call(proc, LIST_1(test));
207
 
            }
208
 
 
209
 
            for (; !NULLP(exps); exps = CDR(exps))
210
 
                ret = EVAL(CAR(exps), env);
211
 
 
212
 
            return ret;
213
 
        }
214
 
    }
215
 
 
216
 
    /* "reraise" exception */
217
 
    if (NULLP(CURRENT_EXCEPTION_CONTINUATION()))
218
 
        ERR("guard: cannot reraise exception");
219
 
    ScmOp_SRFI34_raise(thrown);
220
 
 
221
 
    /* never reaches here */
222
 
    return SCM_UNDEF;
223
 
}
224
 
 
225
 
/*
226
 
 * FIXME:
227
 
 * - Reimplement with dynamic-wind as "Reference Implementation" of SRFI-34
228
 
 *   does, without direct use of setjmp/longjmp
229
 
 * - Cause error when the current exception handler returns, as "Reference
230
 
 *   Implementation" of SRFI-34 does. current implementation allows writing
231
 
 *   unspecified behavior
232
 
 */
233
 
ScmObj ScmOp_SRFI34_raise(ScmObj obj)
234
 
{
235
 
    jmp_buf *env;
236
 
    DECLARE_FUNCTION("raise", ProcedureFixed1);
237
 
 
238
 
    exception_thrown_obj = obj;
239
 
 
240
 
    env = CONTINUATION_JMPENV(CURRENT_EXCEPTION_CONTINUATION());
241
 
    longjmp(*env, 1);
242
 
 
243
 
    /* never reaches here */
244
 
    return SCM_UNDEF;
245
 
}