← Back to branch summary

~ubuntu-branches/ubuntu/quantal/gclcvs/quantal

« back to all changes in this revision

Viewing changes to o/catch.c

  • Committer: Bazaar Package Importer
  • Author(s): Camm Maguire
  • Date: 2004-06-24 15:13:46 UTC
  • Revision ID: james.westby@ubuntu.com-20040624151346-xh0xaaktyyp7aorc
Tags: 2.7.0-26
C_GC_OFFSET is 2 on m68k-linux

Show diffs side-by-side

added added

removed removed

Lines of Context:
o/catch.c
 
1
/*
 
2
 Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
 
3
 
 
4
This file is part of GNU Common Lisp, herein referred to as GCL
 
5
 
 
6
GCL is free software; you can redistribute it and/or modify it under
 
7
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
 
8
the Free Software Foundation; either version 2, or (at your option)
 
9
any later version.
 
10
 
 
11
GCL is distributed in the hope that it will be useful, but WITHOUT
 
12
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
 
13
FITNESS FOR A PARTICULAR PURPOSE.  See the GNU Library General Public 
 
14
License for more details.
 
15
 
 
16
You should have received a copy of the GNU Library General Public License 
 
17
along with GCL; see the file COPYING.  If not, write to the Free Software
 
18
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
 
19
 
 
20
*/
 
21
 
 
22
/*
 
23
 
 
24
        catch.c
 
25
 
 
26
        dynamic non-local exit
 
27
*/
 
28
 
 
29
#include "include.h"
 
30
 
 
31
static void
 
32
FFN(Fcatch)(VOL object args)
 
33
{
 
34
 
 
35
        object *top = vs_top;
 
36
 
 
37
        if (endp(args))
 
38
                FEtoo_few_argumentsF(args);
 
39
        eval(MMcar(args));
 
40
        vs_top = top;
 
41
        vs_push(vs_base[0]);
 
42
        frs_push(FRS_CATCH, vs_base[0]);
 
43
        if (nlj_active)
 
44
                nlj_active = FALSE;
 
45
        else
 
46
                Fprogn(MMcdr(args));
 
47
        frs_pop();
 
48
}
 
49
 
 
50
DEFUN_NEW("ERROR-SET",object,fSerror_set,SI
 
51
           ,1,1,NONE,OO,OO,OO,OO,(volatile object x0),
 
52
       "Evaluates the FORM in the null environment.  If the evaluation \
 
53
of the FORM has successfully completed, SI:ERROR-SET returns NIL as the first \
 
54
value and the result of the evaluation as the rest of the values.  If, in the \
 
55
course of the evaluation, a non-local jump from the FORM is atempted, \
 
56
SI:ERROR-SET traps the jump and returns the corresponding jump tag as its \
 
57
value.")
 
58
 
 
59
{
 
60
        object *old_lex = lex_env;
 
61
 
 
62
        /* 1 args */
 
63
        vs_push(Cnil);
 
64
        frs_push(FRS_CATCHALL, Cnil);
 
65
        if (nlj_active) {
 
66
                nlj_active = FALSE;
 
67
                x0 = nlj_tag;
 
68
                frs_pop();
 
69
                lex_env = old_lex;
 
70
                RETURN1(x0);
 
71
        } else {
 
72
                lex_env = vs_top;
 
73
                vs_push(Cnil);
 
74
                vs_push(Cnil);
 
75
                vs_push(Cnil);
 
76
                x0 = Ieval(x0);
 
77
        }
 
78
        frs_pop();
 
79
        lex_env = old_lex;
 
80
        {int i = fcall.nvalues;
 
81
        if (i+1>=sizeof(fcall.values)/sizeof(*fcall.values))
 
82
          FEerror("Too many function call values",0);
 
83
        while (i > 0)
 
84
        { fcall.values[i+1] = fcall.values[i];
 
85
          i--;}
 
86
         fcall.nvalues++;
 
87
         fcall.values[1] = x0;}
 
88
        return Cnil;
 
89
}
 
90
 
 
91
static void
 
92
FFN(Funwind_protect)(VOL object args)
 
93
{
 
94
 
 
95
        object *top = vs_top;
 
96
        object *value_top;
 
97
        if (endp(args))
 
98
                FEtoo_few_argumentsF(args);
 
99
        frs_push(FRS_PROTECT, Cnil);
 
100
        if (nlj_active) {
 
101
                object tag = nlj_tag;
 
102
                frame_ptr fr = nlj_fr;
 
103
 
 
104
                value_top = vs_top;
 
105
                vs_top = top;
 
106
                while(vs_base<value_top) {
 
107
                        vs_push(vs_base[0]);
 
108
                        vs_base++;
 
109
                }
 
110
                value_top = vs_top;
 
111
                nlj_active = FALSE;
 
112
                frs_pop();
 
113
                Fprogn(MMcdr(args));
 
114
                vs_base = top;
 
115
                vs_top = value_top;
 
116
                if (vs_top == vs_base) vs_base[0] = Cnil;
 
117
                unwind(fr, tag);
 
118
                /* never reached */
 
119
        } else {
 
120
                eval(MMcar(args));
 
121
                frs_pop();
 
122
                value_top = vs_top;
 
123
                vs_top = top;
 
124
                while(vs_base<value_top) {
 
125
                        vs_push(vs_base[0]);
 
126
                        vs_base++;
 
127
                }
 
128
                value_top = vs_top;
 
129
                Fprogn(MMcdr(args));
 
130
                vs_base = top;
 
131
                vs_top = value_top;
 
132
                if (vs_top == vs_base) vs_base[0] = Cnil;
 
133
        }
 
134
}
 
135
 
 
136
static void
 
137
FFN(Fthrow)(object args)
 
138
{
 
139
 
 
140
        object *top = vs_top;
 
141
        object tag;
 
142
        frame_ptr fr;
 
143
        if (endp(args) || endp(MMcdr(args)))
 
144
                FEtoo_few_argumentsF(args);
 
145
        if (!endp(MMcddr(args)))
 
146
                FEtoo_many_argumentsF(args);
 
147
        eval(MMcar(args));
 
148
        vs_top = top;
 
149
        tag = vs_base[0];
 
150
        vs_push(tag);
 
151
        fr = frs_sch_catch(tag);
 
152
        if (fr == NULL)
 
153
                FEerror("~S is an undefined tag.", 1, tag);
 
154
        eval(MMcadr(args));
 
155
        unwind(fr, tag);
 
156
        /* never reached */
 
157
}
 
158
 
 
159
void
 
160
gcl_init_catch(void)
 
161
{
 
162
        make_special_form("CATCH", Fcatch);
 
163
        make_special_form("UNWIND-PROTECT", Funwind_protect);
 
164
        make_special_form("THROW", Fthrow);
 
165
}