This is catch.c in view mode; [Download] [Up]
/*
Copyright (C) 1994 M. Hagiya, W. Schelter, T. Yuasa
This file is part of GNU Common Lisp, herein referred to as GCL
GCL is free software; you can redistribute it and/or modify it under
the terms of the GNU LIBRARY GENERAL PUBLIC LICENSE as published by
the Free Software Foundation; either version 2, or (at your option)
any later version.
GCL is distributed in the hope that it will be useful, but WITHOUT
ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or
FITNESS FOR A PARTICULAR PURPOSE. See the GNU Library General Public
License for more details.
You should have received a copy of the GNU Library General Public License
along with GCL; see the file COPYING. If not, write to the Free Software
Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
*/
/*
catch.c
dynamic non-local exit
*/
#include "include.h"
Fcatch(args)
object args;
{
object endp_temp;
object *top = vs_top;
object tag;
if (endp(args))
FEtoo_few_argumentsF(args);
eval(MMcar(args));
vs_top = top;
vs_push(vs_base[0]);
frs_push(FRS_CATCH, vs_base[0]);
if (nlj_active)
nlj_active = FALSE;
else
Fprogn(MMcdr(args));
frs_pop();
}
DEFUNO("ERROR-SET",object,fSerror_set,SI
,1,1,NONE,OO,OO,OO,OO,siLerror_set,
"Evaluates the FORM in the null environment. If the evaluation \
of the FORM has successfully completed, SI:ERROR-SET returns NIL as the first \
value and the result of the evaluation as the rest of the values. If, in the \
course of the evaluation, a non-local jump from the FORM is atempted, \
SI:ERROR-SET traps the jump and returns the corresponding jump tag as its \
value.")
(x0)
object x0;
{
object *old_base = vs_base;
object *value_top;
object *old_lex = lex_env;
/* 1 args */
vs_push(Cnil);
frs_push(FRS_CATCHALL, Cnil);
if (nlj_active) {
nlj_active = FALSE;
x0 = nlj_tag;
frs_pop();
lex_env = old_lex;
RETURN1(x0);
} else {
lex_env = vs_top;
vs_push(Cnil);
vs_push(Cnil);
vs_push(Cnil);
x0 = Ieval(x0);
}
frs_pop();
lex_env = old_lex;
{int i = fcall.nvalues;
while (i > 0)
{ fcall.values[i+1] = fcall.values[i];
i--;}
fcall.nvalues++;
fcall.values[1] = x0;}
return Cnil;
}
Funwind_protect(args)
object args;
{
object endp_temp;
object *top = vs_top;
object *value_top;
if (endp(args))
FEtoo_few_argumentsF(args);
frs_push(FRS_PROTECT, Cnil);
if (nlj_active) {
object tag = nlj_tag;
frame_ptr fr = nlj_fr;
object *base;
value_top = vs_top;
vs_top = top;
while(vs_base<value_top) {
vs_push(vs_base[0]);
vs_base++;
}
value_top = vs_top;
nlj_active = FALSE;
frs_pop();
Fprogn(MMcdr(args));
vs_base = top;
vs_top = value_top;
if (vs_top == vs_base) vs_base[0] = Cnil;
unwind(fr, tag);
/* never reached */
} else {
eval(MMcar(args));
frs_pop();
value_top = vs_top;
vs_top = top;
while(vs_base<value_top) {
vs_push(vs_base[0]);
vs_base++;
}
value_top = vs_top;
Fprogn(MMcdr(args));
vs_base = top;
vs_top = value_top;
if (vs_top == vs_base) vs_base[0] = Cnil;
}
}
Fthrow(args)
object args;
{
object endp_temp;
object *top = vs_top;
object tag;
frame_ptr fr;
if (endp(args) || endp(MMcdr(args)))
FEtoo_few_argumentsF(args);
if (!endp(MMcddr(args)))
FEtoo_many_argumentsF(args);
eval(MMcar(args));
vs_top = top;
tag = vs_base[0];
vs_push(tag);
fr = frs_sch_catch(tag);
if (fr == NULL)
FEerror("~S is an undefined tag.", 1, tag);
eval(MMcadr(args));
unwind(fr, tag);
/* never reached */
}
init_catch()
{
make_special_form("CATCH", Fcatch);
make_special_form("UNWIND-PROTECT", Funwind_protect);
make_special_form("THROW", Fthrow);
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.