This is error.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.
*/
/*
error.c
Errors
*/
#include "include.h"
#include <varargs.h>
object siSuniversal_error_handler;
static object null_string;
object sSterminal_interrupt;
terminal_interrupt(correctable)
{
signals_allowed = sig_normal;
ifuncall1(sSterminal_interrupt, correctable?Ct:Cnil);
}
object
ihs_function_name(x)
object x;
{
object y;
switch (type_of(x)) {
case t_symbol:
return(x);
case t_cons:
y = x->c.c_car;
if (y == sLlambda)
return(sLlambda);
if (y == sLlambda_closure)
return(sLlambda_closure);
if (y == sLlambda_block || y == sSlambda_block_expanded) {
x = x->c.c_cdr;
if (type_of(x) != t_cons)
return(sLlambda_block);
return(x->c.c_car);
}
if (y == sLlambda_block_closure) {
x = x->c.c_cdr;
if (type_of(x) != t_cons)
return(sLlambda_block_closure);
x = x->c.c_cdr;
if (type_of(x) != t_cons)
return(sLlambda_block_closure);
x = x->c.c_cdr;
if (type_of(x) != t_cons)
return(sLlambda_block_closure);
x = x->c.c_cdr;
if (type_of(x) != t_cons)
return(sLlambda_block_closure);
return(x->c.c_car);
}
/* a general special form */
if (y->s.s_sfdef != NOT_SPECIAL)
return y;
return(Cnil);
case t_afun:
case t_closure:
case t_cfun:
case t_sfun:
case t_vfun:
case t_cclosure:
case t_gfun:
return(x->cf.cf_name);
default:
return(Cnil);
}
}
object
ihs_top_function_name(h)
ihs_ptr h;
{
object x;
while (h >= ihs_org) {
x = ihs_function_name(h->ihs_function);
if (x != Cnil)
return(x);
h--;
}
return(Cnil);
}
call_error_handler()
{
super_funcall(siSuniversal_error_handler);
}
object
Icall_error_handler(error_name,error_format_string,nfmt_args,va_alist)
int nfmt_args;
object error_name,error_format_string;
va_dcl
/* n is the total number of args passed to this function */
{ object b[20];
b[0]= error_name;
b[1]= Cnil; /* continue format */
b[2] = ihs_top_function_name(ihs_top);
b[3] = null_string; /*continue format arg*/
b[4] = error_format_string;
{int i = 0;
va_list ap;
va_start(ap);
while (i++ < nfmt_args)
{ b[i+4]= va_arg(ap,object);
}
va_end(ap);
}
return IapplyVector(sSuniversal_error_handler,nfmt_args+5,b);
}
DEFUNO("ERROR",object,fLerror,LISP
,1,F_ARG_LIMIT,NONE,OO,OO,OO,OO,Lerror,"")(fmt_string,va_alist)
object fmt_string;
va_dcl
{ int n = VFUN_NARGS;
va_list ap;
va_start(ap);
RETURN1(Iapply_fun_n(sSuniversal_error_handler,5,n-1,
sKerror,
Cnil,
ihs_top_function_name(ihs_top-1),
null_string,fmt_string,
ap));
va_end(ap);
}
DEFUNO("CERROR",object,fLcerror,LISP
,2,F_ARG_LIMIT,NONE,OO,OO,OO,OO,Lcerror,"")
(continue_fmt_string,fmt_string,va_alist)
object continue_fmt_string,fmt_string;
va_dcl
{ int n = VFUN_NARGS;
va_list ap;
va_start(ap);
RETURN1(Iapply_fun_n(sSuniversal_error_handler,5,n-2,
sKerror,
Ct,
ihs_top_function_name(ihs_top-1),
continue_fmt_string,fmt_string,
ap));
va_end(ap);
}
void
FEerror(s, num, arg1, arg2, arg3, arg4)
char *s;
int num;
object arg1, arg2, arg3, arg4;
{ char *p = s;
int last = 0;
int count = 0;
while (*p) { if (*p=='~' && last != '~')
count ++;
last = *p ; p++;}
VFUN_NARGS = (count == 0 ? 1 : (num > 50 ? count+1 : num+1));
fLerror(make_simple_string(s),arg1,arg2,arg3,arg4);
}
FEwrong_type_argument(type, value)
object type, value;
{Icall_error_handler(sKwrong_type_argument,
make_simple_string("~S is not of type ~S."),
2,(value),(type));
}
FEtoo_few_arguments(base, top)
object *base, *top;
{ Icall_error_handler(sKtoo_few_arguments,
(make_simple_string("~S [or a callee] requires more than ~R argument~:p.")),
2,(ihs_top_function_name(ihs_top)),
(make_fixnum(top - base)));
}
FEtoo_few_argumentsF(args)
object args;
{Icall_error_handler(sKtoo_few_arguments,
make_simple_string("Too few arguments."),
2,(ihs_top_function_name(ihs_top)),
(args));
}
FEtoo_many_arguments(base, top)
object *base, *top;
{ Icall_error_handler(sKtoo_many_arguments,
(make_simple_string("~S [or a callee] requires less than ~R argument~:p.")),
2,(ihs_top_function_name(ihs_top)),(make_fixnum(top - base)));
}
FEtoo_many_argumentsF(args)
object args;
{
Icall_error_handler(sKtoo_many_arguments,
make_simple_string("Too many arguments."),0);
}
FEinvalid_macro_call()
{Icall_error_handler(sKinvalid_form,
(make_simple_string("Invalid macro call to ~S.")),
1,(ihs_top_function_name(ihs_top)));
}
FEunexpected_keyword(key)
object key;
{ if (!keywordp(key))
not_a_keyword(key);
Icall_error_handler(sKunexpected_keyword,
make_simple_string("~S does not allow the keyword ~S."),
2,(ihs_top_function_name(ihs_top)),(key));
}
FEinvalid_form(s, form)
char *s;
object form;
{Icall_error_handler(sKinvalid_form,make_simple_string(s),
1,(form));
}
FEunbound_variable(sym)
object sym;
{Icall_error_handler(sKunbound_variable,
make_simple_string("The variable ~S is unbound."),
1,(sym));
}
FEinvalid_variable(s, obj)
char *s;
object obj;
{Icall_error_handler(sKinvalid_variable,make_simple_string(s),
1,(obj));
}
FEundefined_function(fname)
object fname;
{Icall_error_handler(sKundefined_function,
make_simple_string("The function ~S is undefined."),
1,(fname));
}
FEinvalid_function(obj)
object obj;
{Icall_error_handler(sKinvalid_function,
make_simple_string("~S is invalid as a function."),
1,(obj));
}
object
CEerror(error_str, cont_str, num, arg1, arg2, arg3, arg4)
char *error_str, *cont_str;
int num;
object arg1, arg2, arg3, arg4;
{
VFUN_NARGS=num+2;
return fLcerror(make_simple_string(cont_str),
make_simple_string(error_str),
arg1,arg2,arg3,arg4);
}
/*
Lisp interface to IHS
*/
ihs_ptr get_ihs_ptr(x)
object x;
{
ihs_ptr p;
if (type_of(x) != t_fixnum)
goto ILLEGAL;
p = ihs_org + fix(x);
if (fix(x)==0) return p;
if (ihs_org <= p && p <= ihs_top)
return(p);
ILLEGAL:
FEerror("~S is an illegal ihs index.", 1, x);
}
DEFUNO("IHS-TOP",object,fSihs_top,SI
,0,0,NONE,OO,OO,OO,OO,siLihs_top,"")()
{
/* 0 args */
RETURN1(make_fixnum(ihs_top - ihs_org));
}
DEFUNO("IHS-FUN",object,fSihs_fun,SI
,1,1,NONE,OO,OO,OO,OO,siLihs_fun,"")(x0)
object x0;
{
/* 1 args */
x0 = get_ihs_ptr(x0)->ihs_function;
RETURN1(x0);
}
DEFUNO("IHS-VS",object,fSihs_vs,SI
,1,1,NONE,OO,OO,OO,OO,siLihs_vs,"")(x0)
object x0;
{
/* 1 args */
x0 = make_fixnum(get_ihs_ptr(x0)->ihs_base - vs_org);
RETURN1(x0);
}
frame_ptr get_frame_ptr(x)
object(x);
{
frame_ptr p;
if (type_of(x) != t_fixnum)
goto ILLEGAL;
p = frs_org + fix(x);
if (fix(x)==0) return p;
if (frs_org <= p && p <= frs_top)
return(p);
ILLEGAL:
FEerror("~S is an illegal frs index.", 1, x);
}
DEFUNO("FRS-TOP",object,fSfrs_top,SI
,0,0,NONE,OO,OO,OO,OO,siLfrs_top,"")()
{
/* 0 args */
RETURN1((make_fixnum(frs_top - frs_org)));
}
DEFUNO("FRS-VS",object,fSfrs_vs,SI
,1,1,NONE,OO,OO,OO,OO,siLfrs_vs,"")(x0)
object x0;
{
/* 1 args */
x0 = make_fixnum(get_frame_ptr(x0)->frs_lex - vs_org);
RETURN1(x0);
}
DEFUNO("FRS-BDS",object,fSfrs_bds,SI
,1,1,NONE,OO,OO,OO,OO,siLfrs_bds,"")(x0)
object x0;
{
/* 1 args */
x0
= make_fixnum(get_frame_ptr(x0)->frs_bds_top - bds_org);
RETURN1(x0);
}
DEFUNO("FRS-CLASS",object,fSfrs_class,SI
,1,1,NONE,OO,OO,OO,OO,siLfrs_class,"")(x0)
object x0;
{
enum fr_class c;
/* 1 args */
c = get_frame_ptr(x0)->frs_class;
if (c == FRS_CATCH) x0 = sKcatch;
else if (c == FRS_PROTECT) x0 = sKprotect;
else if (c == FRS_CATCHALL) x0 = sKcatchall;
else FEerror("Unknown frs class was detected.", 0);
RETURN1(x0);
}
DEFUNO("FRS-TAG",object,fSfrs_tag,SI
,1,1,NONE,OO,OO,OO,OO,siLfrs_tag,"")(x0)
object x0;
{
/* 1 args */
x0 = get_frame_ptr(x0)->frs_val;
RETURN1(x0);
}
DEFUNO("FRS-IHS",object,fSfrs_ihs,SI
,1,1,NONE,OO,OO,OO,OO,siLfrs_ihs,"")(x0)
object x0;
{
/* 1 args */
x0
= make_fixnum(get_frame_ptr(x0)->frs_ihs - ihs_org);
RETURN1(x0);
}
bds_ptr get_bds_ptr(x)
object(x);
{
bds_ptr p;
if (type_of(x) != t_fixnum)
goto ILLEGAL;
p = bds_org + fix(x);
if (0 == fix(x)) return p;
if (bds_org <= p && p <= bds_top)
return(p);
ILLEGAL:
FEerror("~S is an illegal bds index.", 1, x);
}
DEFUNO("BDS-TOP",object,fSbds_top,SI
,0,0,NONE,OO,OO,OO,OO,siLbds_top,"")()
{
/* 0 args */
RETURN1((make_fixnum(bds_top - bds_org)));
}
DEFUNO("BDS-VAR",object,fSbds_var,SI
,1,1,NONE,OO,OO,OO,OO,siLbds_var,"")(x0)
object x0;
{
/* 1 args */
x0 = get_bds_ptr(x0)->bds_sym;
RETURN1(x0);
}
DEFUNO("BDS-VAL",object,fSbds_val,SI
,1,1,NONE,OO,OO,OO,OO,siLbds_val,"")(x0)
object x0;
{
/* 1 args */
x0 = get_bds_ptr(x0)->bds_val;
RETURN1(x0);
}
object *get_vs_ptr(x)
object(x);
{
object *p;
if (type_of(x) != t_fixnum)
goto ILLEGAL;
p = vs_org + fix(x);
if (vs_org <= p && p < vs_top)
return(p);
ILLEGAL:
FEerror("~S is an illegal vs index.", 1, x);
}
DEFUNO("VS-TOP",object,fSvs_top,SI
,0,0,NONE,OO,OO,OO,OO,siLvs_top,"")()
{
object x;
/* 0 args */
x = (make_fixnum(vs_top - vs_org));
RETURN1(x);
}
DEFUNO("VS",object,fSvs,SI
,1,1,NONE,OO,OO,OO,OO,siLvs,"")(x0)
object x0;
{
/* 1 args */
x0 = *get_vs_ptr(x0);
RETURN1(x0);
}
DEFUNO("SCH-FRS-BASE",object,fSsch_frs_base,SI
,2,2,NONE,OO,OO,OO,OO,siLsch_frs_base,"") (x0,x1)
object x0,x1;
{
frame_ptr x;
ihs_ptr y;
/* 2 args */
y = get_ihs_ptr(x1);
for (x = get_frame_ptr(x0);
x <= frs_top && x->frs_ihs < y;
x++);
if (x > frs_top) x0 = Cnil;
else x0 = make_fixnum(x - frs_org);
RETURN1(x0);
}
DEFUNO("INTERNAL-SUPER-GO",object,fSinternal_super_go,SI
,3,3,NONE,OO,OO,OO,OO,siLinternal_super_go,"")(tag,x1,x2)
object tag,x1,x2;
{
frame_ptr fr;
/* 3 args */
fr = frs_sch(tag);
if (fr == NULL)
FEerror("The tag ~S is missing.", 1, tag);
if (x2 == Cnil)
tag = x1;
else
tag = MMcons(tag, x1);
unwind(fr,tag);
RETURN0 ;
}
DEF_ORDINARY("UNIVERSAL-ERROR-HANDLER",sSuniversal_error_handler,SI
,"Redefined in lisp, this is the function called by the \
internal error handling mechanism. \
Args: (error-name correctable function-name \
continue-format-string error-format-string \
&rest args)");
DEFUNO("UNIVERSAL-ERROR-HANDLER",object,fSuniversal_error_handler,SI
,5,F_ARG_LIMIT,NONE,OO,OO,OO,OO,
siLuniversal_error_handler,"")(x0,x1,x2,x3,error_fmt_string)
object x0,x1,x2,x3,error_fmt_string;
{
int i;
/* 5 args */
for (i = 0; i < error_fmt_string->st.st_fillp; i++)
putchar(error_fmt_string->st.st_self[i]);
printf("\nLisp initialization failed.\n");
exit(0);
RETURN1(x0);
}
check_arg_failed(n)
int n;
{
FEerror("Expected ~S args but received ~S args",2,
make_fixnum(n),make_fixnum(vs_top-vs_base));
}
too_few_arguments()
{
FEtoo_few_arguments(vs_base, vs_top);
}
too_many_arguments()
{
FEtoo_many_arguments(vs_base, vs_top);
}
ck_larg_at_least(n, x)
int n; object x;
{ object endp_temp;
for(; n > 0; n--, x = x->c.c_cdr)
if(endp(x))
FEerror("APPLY sended too few arguments to LAMBDA.", 0);
}
ck_larg_exactly(n, x)
int n; object x;
{ object endp_temp;
for(; n > 0; n--, x = x->c.c_cdr)
if(endp(x))
FEerror("APPLY sended too few arguments to LAMBDA.", 0);
if(!endp(x)) FEerror("APPLY sended too many arguments to LAMBDA.", 0);
}
invalid_macro_call()
{
FEinvalid_macro_call();
}
keyword_value_mismatch()
{
FEerror("Keywords and values do not match.", 0);
}
not_a_keyword(x)
object x;
{
FEerror("~S is not a keyword.", 1, x);
}
unexpected_keyword(key)
object key;
{
FEunexpected_keyword(key);
}
object
wrong_type_argument(typ, obj)
object typ, obj;
{
FEwrong_type_argument(typ, obj);
/* no return */
}
illegal_declare(form)
{
FEinvalid_form("~S is an illegal declaration form.", form);
}
not_a_string(obj)
object obj;
{ FEwrong_type_argument(obj,sLstring);
}
not_a_symbol(obj)
object obj;
{
FEinvalid_variable("~S is not a symbol.", obj);
}
not_a_variable(obj)
object obj;
{
FEinvalid_variable("~S is not a variable.", obj);
}
illegal_index(x, i)
object x, i;
{
FEerror("~S is an illegal index to ~S.", 2, i, x);
}
object
LVerror(va_alist)
va_dcl
{va_list ap;
va_start(ap);
fcall.fun= make_cfun(Lerror,Cnil,Cnil,0,0);
fcalln_general(ap);
va_end(ap);
return Cnil;
}
int
vfun_wrong_number_of_args(x)
object x;
{
FEerror("Expected ~S args but received ~S args",2,
x,make_fixnum(VFUN_NARGS));
}
check_arg_range(n,m)
int n,m;
{ if (VFUN_NARGS < n)
Icall_error_handler(
sKtoo_few_arguments,
make_simple_string("Needed at least ~D args, but received ~d"),
2,make_fixnum(n),make_fixnum(VFUN_NARGS));
else if (VFUN_NARGS > m)
Icall_error_handler(
sKtoo_many_arguments,
make_simple_string("Needed no more than ~D args, but received ~d"),
2,make_fixnum(m),make_fixnum(VFUN_NARGS));
}
DEF_ORDINARY("TERMINAL-INTERRUPT",sSterminal_interrupt,SI,"");
DEF_ORDINARY("WRONG-TYPE-ARGUMENT",sKwrong_type_argument,KEYWORD,"");
DEF_ORDINARY("TOO-FEW-ARGUMENTS",sKtoo_few_arguments,KEYWORD,"");
DEF_ORDINARY("TOO-MANY-ARGUMENTS",sKtoo_many_arguments,KEYWORD,"");
DEF_ORDINARY("UNEXPECTED-KEYWORD",sKunexpected_keyword,KEYWORD,"");
DEF_ORDINARY("INVALID-FORM",sKinvalid_form,KEYWORD,"");
DEF_ORDINARY("UNBOUND-VARIABLE",sKunbound_variable,KEYWORD,"");
DEF_ORDINARY("INVALID-VARIABLE",sKinvalid_variable,KEYWORD,"");
DEF_ORDINARY("UNDEFINED-FUNCTION",sKundefined_function,KEYWORD,"");
DEF_ORDINARY("INVALID-FUNCTION",sKinvalid_function,KEYWORD,"");
DEF_ORDINARY("CATCH",sKcatch,KEYWORD,"");
DEF_ORDINARY("PROTECT",sKprotect,KEYWORD,"");
DEF_ORDINARY("CATCHALL",sKcatchall,KEYWORD,"");
init_error()
{
make_function("ERROR", Lerror);
make_function("CERROR", Lcerror);
make_si_function("IHS-TOP", siLihs_top);
null_string = make_simple_string("");
enter_mark_origin(&null_string);
}
These are the contents of the former NiCE NeXT User Group NeXTSTEP/OpenStep software archive, currently hosted by Netfuture.ch.