diff -uNr TEST.gcl/gcl/o/alloc.c agcl/agcl/o/alloc.c --- TEST.gcl/gcl/o/alloc.c Sun Oct 27 16:35:06 2002 +++ agcl/agcl/o/alloc.c Tue Nov 5 15:17:47 2002 @@ -543,7 +543,9 @@ rb_limit = rb_end - 2*RB_GETA; if (page(rb_end) - page(heap_end) != holepage + nrbpage) - FEerror("bad rb_end",0); + Icall_error_handler(sKsimple_storage_condition, + make_simple_string("bad rb_end"), + 0); alloc_page(-( nrbpage + holepage)); g = FALSE; call_after_gbc_hook(t_relocatable); @@ -737,10 +739,11 @@ { RETURN1((inheap(x->ust.ust_self) ? sLt : sLnil)); } +/* void cant_get_a_type(void) { FEerror("Can't get a type.", 0); -} + }*/ DEFUNO("ALLOCATE",object,fSallocate,SI ,2,3,NONE,OO,IO,OO,OO,siLallocate,"")(type,npages,va_alist) @@ -766,7 +769,9 @@ CHECK_ARG_RANGE(2,3); t= t_from_type(type); if (npages <= 0) - FEerror("Allocate takes positive argument.", 1, + Icall_error_handler(sLsimple_type_error, + make_simple_string("Allocate takes positive argument, not ~A."), + 1, make_fixnum(npages)); tm = tm_of(t); if (tm->tm_npage > npages) {npages=tm->tm_npage;} @@ -788,8 +793,11 @@ if (available_pages < tm->tm_maxpage - tm->tm_npage || (pp = alloc_page(tm->tm_maxpage - tm->tm_npage)) == NULL) { - FEerror("Can't allocate ~D pages for ~A.", 2, - make_fixnum(npages), (make_simple_string(tm->tm_name+1))); + Icall_error_handler(sKsimple_storage_condition, + make_simple_string("Can't allocate ~D pages for ~A."), + 2, + make_fixnum(npages), + (make_simple_string(tm->tm_name+1))); } for (; tm->tm_npage < tm->tm_maxpage; pp += PAGESIZE) add_page_to_freelist(pp,tm);} @@ -809,7 +817,9 @@ 0==strncmp((tm->tm_name)+1,type->st.st_self,type->st.st_fillp) ) return i;} - FEerror("Unrecognized type",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Unrecognized type"), + 0); return i; } @@ -888,7 +898,9 @@ CHECK_ARG_RANGE(1,2); if (npages < 0) - FEerror("Allocate requires positive argument.", 0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Allocate requires positive argument."), + 0); if (ncbpage > npages) { printf("Allocate contiguous %d: %d already there pages",npages,ncbpage); npages=ncbpage; @@ -898,9 +910,10 @@ RETURN1(Ct); m = maxcbpage - ncbpage; if (available_pages < m || (p = alloc_page(m)) == NULL) - FEerror("Can't allocate ~D pages for contiguous blocks.", - 1, make_fixnum(npages)); - + Icall_error_handler(sKsimple_storage_condition, + make_simple_string("Can't allocate ~D pages for contiguous blocks."), + 1, + make_fixnum(npages)); for (i = 0; i < m; i++) type_map[page(p + PAGESIZE*i)] = (char)t_contiguous; @@ -945,11 +958,15 @@ CHECK_ARG_RANGE(1,2); if (npages <= 0) - FEerror("Requires positive arg",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Requires positive arg"), + 0); if ((nrbpage > npages && rb_pointer >= rb_start + PAGESIZE*npages - 2*RB_GETA) || 2*npages > real_maxpage-page(heap_end)-new_holepage-real_maxpage/32) - FEerror("Can't set the limit for relocatable blocks to ~D.", - 1, make_fixnum(npages)); + Icall_error_handler(sKsimple_storage_condition, + make_simple_string("Can't set the limit for relocatable blocks to ~D."), + 1, + make_fixnum(npages)); rb_end += (npages-nrbpage)*PAGESIZE; nrbpage = npages; rb_limit = rb_end - 2*RB_GETA; @@ -994,13 +1011,19 @@ if (npages < 1 || npages > real_maxpage - page(heap_end) - 2*nrbpage - real_maxpage/32) - FEerror("Illegal value for the hole size.", 0); + Icall_error_handler(sKsimple_storage_condition, + make_simple_string("Illegal value for the hole size."), + 0); new_holepage = npages; if (VFUN_NARGS ==2) - { + { + Icall_error_handler(sKsimple_storage_condition, + make_simple_string("Illegal value for the hole size."), + 0); if (reserve <0 || reserve > new_holepage) - FEerror("Illegal value for the hole size.", 0); - reserve_pages_for_signal_handler = reserve;} + + reserve_pages_for_signal_handler = reserve; + } RETURN2(make_fixnum(npages), make_fixnum(reserve_pages_for_signal_handler)); @@ -1159,7 +1182,9 @@ #ifdef NOFREE_ERR return ; #else - FEerror("free(3) error.",0); + Icall_error_handler(sKsimple_storage_condition, + make_simple_string("free(3) error."), + 0); return; #endif } @@ -1203,7 +1228,9 @@ return(x->st.st_self); } } - FEerror("realloc(3) error.", 0); + Icall_error_handler(sKsimple_storage_condition, + make_simple_string("realloc(3) error."), + 0); return NULL; diff -uNr TEST.gcl/gcl/o/array.c agcl/agcl/o/array.c --- TEST.gcl/gcl/o/array.c Tue Sep 24 21:01:45 2002 +++ agcl/agcl/o/array.c Mon Nov 4 17:54:13 2002 @@ -70,7 +70,10 @@ unsigned int k; int rank = n - 1; if (x->a.a_rank != rank) - FEerror(" ~a has wrong rank",1,x); + Icall_error_handler(sLsimple_error, + make_simple_string("~A has wrong rank."), + 1, + x); if (rank == 1) return fSaref1(x,i); if (rank == 0) return fSaref1(x,0); va_start(ap); @@ -82,7 +85,10 @@ while(1) { if ( k >= x->a.a_dims[m]) - FEerror("Index ~a to array is too large",1,make_fixnum (m)); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Index ~a to array is too large"), + 1, + make_fixnum (m)); i1 += k; m ++; if (m <= rank) @@ -99,7 +105,10 @@ return fSaref1(x,i1); } if (n > 2) - { FEerror("Too many args (~a) to aref",1,make_fixnum(n));} + { Icall_error_handler(sLsimple_error, + make_simple_string("Too many args (~a) to aref"), + 1, + make_fixnum(n));} return fSaref1(x,i); } @@ -113,9 +122,15 @@ case t_bitvector: case t_string: if ((unsigned int) i >= x->a.a_dim) - FEerror("Array index ~a out of bounds for ~a", 2, make_fixnum(i),x); + Icall_error_handler(sLsimple_error, + make_simple_string("Array index ~a out of bounds for ~a"), + 2, + make_fixnum(i), + x); default: - FEerror("not an array",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("not an array"), + 0); } } @@ -131,7 +146,10 @@ && x->v.v_dim > i) RETURN1(x->v.v_self[i]); if (x->v.v_dim > i) illegal_index(x,make_fixnum(i)); - FEerror("Bad simple vector ~a",1,x); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Bad simple vector ~A"), + 1, + x); return(Cnil); } @@ -173,14 +191,18 @@ return make_fixnum(USHORT(x, i)); default: - FEerror("unknown array type",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("unknown array type"), + 0); } case t_string: if (x->v.v_dim <= i) /* i = */fScheck_bounds_bounds(x, i); return code_char(x->st.st_self[i]); default: - FEerror("not an array",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Not an array."), + 0); return(Cnil); } } @@ -251,7 +273,9 @@ USHORT(x, i) = Mfix(val); break; default: - FEerror("unknown array type",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Unknown array type"), + 0); } break; case t_string: @@ -261,7 +285,9 @@ x->st.st_self[i] = char_code(val); break; default: - FEerror("not an array",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("not an array"), + 0); } return val; } @@ -281,7 +307,10 @@ unsigned int k; int rank = n - 2; if (x->a.a_rank != rank) - FEerror(" ~a has wrong rank",1,x); + Icall_error_handler(sLsimple_error, + make_simple_string(" ~a has wrong rank"), + 1, + x); if (rank == 0) return fSaset1(x,make_fixnum(0),ii); ASSURE_TYPE(ii,t_fixnum); i = fix(ii); @@ -296,8 +325,11 @@ while(1) { if (k >= x->a.a_dims[m]) - FEerror("Index number ~a: ~a to array is out of bounds", - 2,make_fixnum (m),make_fixnum(k)); + Icall_error_handler(sLsimple_error, + make_simple_string("Index number ~a: ~a to array is out of bounds"), + 2, + make_fixnum (m), + make_fixnum(k)); i1 += k; if (m < rank) {object u; @@ -335,7 +367,9 @@ || DISPLACED_TO(x) != Cnil) Wrong_type_error("simple array",0); if (i > x->v.v_dim) - { FEerror("out of bounds",0); + { Icall_error_handler(sLsimple_error, + make_simple_string("out of bounds"), + 0); } return x->v.v_self[i] = val; } @@ -391,7 +425,9 @@ if(type_of(fillp) == t_fixnum) { x->v.v_fillp = Mfix(fillp); - if (x->v.v_fillp > n || x->v.v_fillp < 0) FEerror("bad fillp",0); + if (x->v.v_fillp > n || x->v.v_fillp < 0) Icall_error_handler(sLsimple_error, + make_simple_string("bad fillp"), + 0); x->v.v_hasfillp = 1; } else @@ -544,7 +580,9 @@ while (i < rank) { x->a.a_dims[i] = FIX_CHECK(Mcar(v)); if (x->a.a_dims[i] < 0) - { FEerror("Dimension must be non negative",0);} + { Icall_error_handler(sLsimple_type_error, + make_simple_string("Dimension must be non negative"), + 0);} dim *= x->a.a_dims[i++]; v = Mcdr(v);} x->a.a_dim = dim; @@ -596,12 +634,16 @@ n = vs_top - vs_base; if (n != 1) - FEerror("Wrong number of arguments",0); + Icall_error_handler(sLsimple_error, + make_simple_string("Wrong number of arguments"), + 0); array = vs_base[0]; vs_base=vs_top; if (type_of(array)!=t_array && type_of(array)!=t_vector) - FEerror("Argument is not an array",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Argument is not an array"), + 0); a=array->a.a_displaced->c.c_car; if (a==Cnil) { @@ -617,7 +659,9 @@ s=aet_sizes[Iarray_element_type(a)]; n=(void *)array->a.a_self-(void *)a->a.a_self; if (n%s) - FEerror("Array is displaced by fractional elements",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Array is displaced by fractional elements") + ,0); vs_push(a); vs_push(make_fixnum(n/s)); @@ -652,7 +696,9 @@ { Wrong_type_error("same element type",0); } if (offset + from_array->a.a_dim > dest_array->a.a_dim) - { FEerror("Destination array too small to hold other array",0); + { Icall_error_handler(sLsimple_error, + make_simple_string("Destination array too small to hold other array"), + 0); } /* ensure that we have a cons */ if (dest_array->a.a_displaced == Cnil) @@ -698,7 +744,10 @@ t = aet_ch; break; default: - FEerror("Not an array ~a ",1,x); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Not an array ~A."), + 1, + x); } return t; } @@ -714,9 +763,13 @@ t1 = Iarray_element_type(from); t2 = Iarray_element_type(to); if (t1 != t2) - FEerror("Attempt to displace arrays of one type to arrays of another type",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Attempt to displace arrays of one type to arrays of another type"), + 0); if (to->a.a_dim > from->a.a_dim - displaced_index_offset) - FEerror("To array not large enough for displacement",0); + Icall_error_handler(sLsimple_error, + make_simple_string("To-array not large enough for displacement"), + 0); {BEGIN_NO_INTERRUPT; from->a.a_displaced = make_cons(to,Cnil); if (to->a.a_displaced == Cnil) @@ -772,7 +825,9 @@ case aet_uchar: STORE_TYPED(&u, unsigned char, Mfix(x)); case aet_short: STORE_TYPED(&u, short, Mfix(x)); case aet_ushort: STORE_TYPED(&u,unsigned short,Mfix(x)); - default: FEerror("bad elttype",0); + default: Icall_error_handler(sLsimple_type_error, + make_simple_string("bad elttype"), + 0); } return (char *)&u; } @@ -809,7 +864,9 @@ case aet_uchar: GSET(p1,n,unsigned char,val); case aet_short: GSET(p1,n,short,val); case aet_ushort: GSET(p1,n,unsigned short,val); - default: FEerror("bad elttype",0); + default: Icall_error_handler(sLsimple_type_error, + make_simple_string("bad elttype"), + 0); } } @@ -835,7 +892,9 @@ if (typ1==aet_bit) {if (i1 % CHAR_SIZE) badcopy: - FEerror("Bit copies only if aligned",0); + Icall_error_handler(sLsimple_error, + make_simple_string("Bit copies only if aligned"), + 0); else {int rest=n1%CHAR_SIZE; if (rest!=0 ) @@ -855,11 +914,15 @@ i2=i2/CHAR_SIZE ;} if ((typ1 ==aet_object || typ2 ==aet_object) && typ1 != typ2) - FEerror("Can't copy between different array types",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Can't copy between different array types"), + 0); nc=n1 * aet_sizes[(int)typ1]; if (i1+n1 > x->a.a_dim || ((y->a.a_dim - i2) *aet_sizes[(int)typ2]) < nc) - FEerror("Copy out of bounds",0); + Icall_error_handler(sLsimple_error, + make_simple_string("Copy out of bounds"), + 0); bcopy(x->ust.ust_self + (i1*aet_sizes[(int)typ1]), y->ust.ust_self + (i2*aet_sizes[(int)typ2]), nc); @@ -930,12 +993,19 @@ if (x->v.v_hasfillp == 0) { goto no_fillp;} if (i < 0 || i > x->a.a_dim) - { FEerror("~a is not suitable for a fill pointer for ~a",2,make_fixnum(i),x);} + { Icall_error_handler(sLsimple_type_error, + make_simple_string("~A is not suitable for a fill pointer for ~A"), + 2, + make_fixnum(i), + x);} x->v.v_fillp = i; return make_fixnum(i); no_fillp: - FEerror("~a does not have a fill pointer",1,x); + Icall_error_handler(sLsimple_error, + make_simple_string("~A does not have a fill pointer."), + 1, + x); return make_fixnum(0); } @@ -954,7 +1024,10 @@ return make_fixnum(x->v.v_fillp) ; no_fillp: - FEerror("~a does not have a fill pointer",1,x); + Icall_error_handler(sLsimple_error, + make_simple_string("~a does not have a fill pointer"), + 1, + x); return make_fixnum(0); } @@ -1023,8 +1096,10 @@ { if (type_of(x) == t_array) { if ((unsigned int)i >= x->a.a_rank) - FEerror("Index ~a out of bounds for array-dimension",1 - ,make_fixnum(i)); + Icall_error_handler(sLsimple_error, + make_simple_string("Index ~a out of bounds for array-dimension"), + 1, + make_fixnum(i)); else { return make_fixnum(x->a.a_dims[i]);}} IisArray(x); return make_fixnum(x->v.v_dim); @@ -1040,7 +1115,9 @@ (u->bv.bv_self - ar->bv.bv_self)*BV_BITS +u->bv.bv_dim -dim + BV_OFFSET(u) - BV_OFFSET(ar) > 0) || (ARRAY_BODY_PTR(u,u->a.a_dim) > ARRAY_BODY_PTR(ar,dim))) - FEerror("Bad displacement",0); + Icall_error_handler(sLsimple_error, + make_simple_string("Bad displacement"), + 0); Icheck_displaced(DISPLACED_FROM(u),ar,dim); displaced_list = Mcdr(displaced_list); } @@ -1097,7 +1174,11 @@ if (TYPE_OF(old) != TYPE_OF(new) || (TYPE_OF(old) == t_array && old->a.a_rank != new->a.a_rank)) { - FEerror("Cannot do array replacement ~a by ~a",2,old,new); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Cannot do array replacement ~A by ~A"), + 2, + old, + new); } { int offset = new->ust.ust_self - old->ust.ust_self; object displaced = make_cons(DISPLACED_TO(new),DISPLACED_FROM(old)); diff -uNr TEST.gcl/gcl/o/assignment.c agcl/agcl/o/assignment.c --- TEST.gcl/gcl/o/assignment.c Fri Oct 18 23:28:53 2002 +++ agcl/agcl/o/assignment.c Mon Nov 4 17:54:13 2002 @@ -71,7 +71,10 @@ sym->s.s_dbind = val; else if (type == stp_constant) - FEinvalid_variable("Cannot assign to the constant ~S.", sym); + Icall_error_handler(sLcell_error, + make_simple_string("Cannot assign to the constant ~S."), + 1, + sym); else { vd = lex_var_sch(sym); if(MMnull(vd) || endp(MMcdr(vd))) @@ -93,7 +96,10 @@ do { vs_top = top; if (endp(MMcdr(form))) - FEinvalid_form("No value for ~S.", form->c.c_car); + Icall_error_handler(sLsimple_error, + make_simple_string("No value for ~S."), + 1, + form->c.c_car); setq(MMcar(form),ans=Ieval(MMcadr(form))); form = MMcddr(form); } while (!endp(form)); @@ -111,7 +117,11 @@ object argsv = arg; for (top = old_top; !endp(arg); arg = MMcddr(arg), top++) { if(endp(MMcdr(arg))) - FEinvalid_form("No value for ~S.", arg->c.c_car); + Icall_error_handler(sLsimple_error, + make_simple_string("No value for ~S."), + 1, + arg->c.c_car); + /* FEinvalid_form("No value for ~S.", arg->c.c_car);*/ top[0] = Ieval(MMcadr(arg)); vs_top = top + 1; @@ -130,8 +140,10 @@ if (type_of(symbol) != t_symbol) not_a_symbol(symbol); if ((enum stype)symbol->s.s_stype == stp_constant) - FEinvalid_variable("Cannot assign to the constant ~S.", - symbol); + Icall_error_handler(sLcell_error, + make_simple_string("Cannot assign to the constant ~S."), + 1, + symbol); symbol->s.s_dbind = value; RETURN1(value); } @@ -148,8 +160,10 @@ if (symbol_value(sSAinhibit_macro_specialA) != Cnil) sym->s.s_sfdef = NOT_SPECIAL; } else if (symbol_value(sSAinhibit_macro_specialA) != Cnil) - FEerror("~S, a special form, cannot be redefined.", - 1, sym); + Icall_error_handler(sLsimple_error, + make_simple_string("~S, a special form, cannot be redefined."), + 1, + sym); } sym = clear_compiler_properties(sym,function); if (sym->s.s_hpack == lisp_package && @@ -168,7 +182,9 @@ sym->s.s_gfdef = function; sym->s.s_mflag = FALSE; } else if (car(function) == sLspecial) - FEerror("Cannot define a special form.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Cannot define a special form."), + 0); else if (function->c.c_car == sLmacro) { sym->s.s_gfdef = function->c.c_cdr; sym->s.s_mflag = TRUE; @@ -188,8 +204,10 @@ if (endp(form) || endp(form->c.c_cdr) || !endp(form->c.c_cdr->c.c_cdr)) - FEinvalid_form("~S is an illegal argument to MULTIPLE-VALUE-SETQ", - form); + Icall_error_handler(sLsimple_error, + make_simple_string("~S is an illegal argument to MULTIPLE-VALUE-SETQ"), + 1, + form); vars = form->c.c_car; fcall.values[0]=Ieval(form->c.c_cdr->c.c_car); @@ -212,8 +230,10 @@ if (type_of(sym) != t_symbol) not_a_symbol(sym); if ((enum stype)sym->s.s_stype == stp_constant) - FEinvalid_variable("Cannot unbind the constant ~S.", - sym); + Icall_error_handler(sLcell_error, + make_simple_string("Cannot unbind the constant ~S."), + 1, + sym); sym->s.s_dbind = OBJNULL; RETURN1(sym); } @@ -232,8 +252,10 @@ if (symbol_value(sSAinhibit_macro_specialA) != Cnil) sym->s.s_sfdef = NOT_SPECIAL; } else if (symbol_value(sSAinhibit_macro_specialA) != Cnil) - FEerror("~S, a special form, cannot be redefined.", - 1, sym); + Icall_error_handler(sLsimple_error, + make_simple_string("~S, a special form, cannot be redefined."), + 1, + sym); } remf(&(sym->s.s_plist),sStraced); clear_compiler_properties(sym,Cnil); @@ -259,7 +281,10 @@ do { vs_top = top; if (endp(MMcdr(form))) - FEinvalid_form("No value for ~S.", form->c.c_car); + Icall_error_handler(sLcell_error, + make_simple_string("No value for ~S."), + 1, + form->c.c_car); result = setf(MMcar(form), MMcadr(form)); form = MMcddr(form); } while (!endp(form)); @@ -324,7 +349,10 @@ x = Ieval(Mcar(args)); result = Ieval(form); if (type_of(x) != t_cons) - FEerror("~S is not a cons.", 1, x); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is not a cons."), + 1, + x); Mcar(x) = result; return result; } @@ -332,7 +360,10 @@ x = Ieval(Mcar(args)); result = Ieval(form); if (type_of(x) != t_cons) - FEerror("~S is not a cons.", 1, x); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is not a cons."), + 1, + x); Mcdr(x) = result; return result; } @@ -394,7 +425,9 @@ VS_PUSH_ENV ; /***/ if (!sLsetf->s.s_mflag || sLsetf->s.s_gfdef == OBJNULL) - FEerror("Where is SETF?", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Where is SETF?"), + 0); funcall(sLsetf->s.s_gfdef); return Ieval(vs_base[0]); } @@ -425,7 +458,9 @@ VS_PUSH_ENV ; /***/ if (!sLpush->s.s_mflag || sLpush->s.s_gfdef == OBJNULL) - FEerror("Where is PUSH?", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Where is PUSH?"), + 0); funcall(sLpush->s.s_gfdef); eval(vs_base[0]); } @@ -454,7 +489,9 @@ VS_PUSH_ENV ; /***/ if (!sLpop->s.s_mflag || sLpop->s.s_gfdef == OBJNULL) - FEerror("Where is POP?", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Where is POP?"), + 0); funcall(sLpop->s.s_gfdef); eval(vs_base[0]); } @@ -492,7 +529,9 @@ VS_PUSH_ENV ; /***/ if (!sLincf->s.s_mflag || sLincf->s.s_gfdef == OBJNULL) - FEerror("Where is INCF?", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Where is INCF?"), + 0); funcall(sLincf->s.s_gfdef); eval(vs_base[0]); } @@ -530,7 +569,9 @@ VS_PUSH_ENV ; /***/ if (!sLdecf->s.s_mflag || sLdecf->s.s_gfdef == OBJNULL) - FEerror("Where is DECF?", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Where is DECF?"), + 0); funcall(sLdecf->s.s_gfdef); eval(vs_base[0]); } diff -uNr TEST.gcl/gcl/o/backq.c agcl/agcl/o/backq.c --- TEST.gcl/gcl/o/backq.c Sat Jul 20 09:10:55 2002 +++ agcl/agcl/o/backq.c Mon Nov 4 17:54:13 2002 @@ -103,7 +103,9 @@ return(EVAL); } if (x->c.c_car == siScomma_at || x->c.c_car == siScomma_dot) - FEerror(",@ or ,. has appeared in an illegal position.", 0); + Icall_error_handler(sKsimple_reader_error, + make_simple_string(",@ or ,. has appeared in an illegal position."), + 0); a = backq_car(x->c.c_car); d = backq_cdr(x->c.c_cdr); if (d == QUOTE) @@ -308,7 +310,9 @@ a = backq_car(x); if (a == APPEND || a == NCONC) - FEerror(",@ or ,. has appeared in an illegal position.", 0); + Icall_error_handler(sKsimple_reader_error, + make_simple_string(",@ or ,. has appeared in an illegal position."), + 0); if (a == QUOTE) kwote_cdr(); return(vs_pop); @@ -322,7 +326,9 @@ in = x0; if (backq_level <= 0) - FEerror("A comma has appeared out of a backquote.", 0); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("A comma has appeared out of a backquote."), + 0); c = peek_char(FALSE, in); if (c == code_char('@')) { w = siScomma_at; diff -uNr TEST.gcl/gcl/o/bind.c agcl/agcl/o/bind.c --- TEST.gcl/gcl/o/bind.c Wed Oct 16 05:24:02 2002 +++ agcl/agcl/o/bind.c Mon Nov 4 17:54:13 2002 @@ -98,7 +98,9 @@ bds_check; lambda = vs_head; if (type_of(lambda) != t_cons) - FEerror("No lambda list.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("No lambda list."), + 0); lambda_list = lambda->c.c_car; body = lambda->c.c_cdr; @@ -137,7 +139,10 @@ goto AUX_L; } if ((enum stype)x->s.s_stype == stp_constant) - FEerror("~S is not a variable.", 1, x); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is not a variable."), + 1, + x); vs_push(x); vs_push(Cnil); nreq++; @@ -571,7 +576,10 @@ switch (var->s.s_stype) { case stp_constant: - FEerror("Cannot bind the constant ~S.", 1, var); + Icall_error_handler(sLcell_error, + make_simple_string("Cannot bind the constant ~S."), + 1, + var); case stp_special: bds_bind(var, val); @@ -597,7 +605,9 @@ void illegal_lambda(void) { - FEerror("Illegal lambda expression.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Illegal lambda expression."), + 0); } /* diff -uNr TEST.gcl/gcl/o/block.c agcl/agcl/o/block.c --- TEST.gcl/gcl/o/block.c Tue Sep 24 21:01:45 2002 +++ agcl/agcl/o/block.c Mon Nov 4 17:54:13 2002 @@ -76,10 +76,16 @@ FEtoo_many_argumentsF(args); lex_block = lex_block_sch(MMcar(args)); if (MMnull(lex_block)) - FEerror("The block name ~S is undefined.", 1, MMcar(args)); + Icall_error_handler(sKsimple_program_error, + make_simple_string("Syntax error: The block name ~S is undefined."), + 1, + MMcar(args)); fr = frs_sch(MMcaddr(lex_block)); if(fr == NULL) - FEerror("The block ~S is missing.", 1, MMcar(args)); + Icall_error_handler(sKsimple_program_error, + make_simple_string("The block ~S is missing."), + 1, + MMcar(args)); if(endp(MMcdr(args))) { vs_base = vs_top; vs_push(Cnil); @@ -100,10 +106,16 @@ FEtoo_many_argumentsF(args); lex_block = lex_block_sch(Cnil); if (MMnull(lex_block)) - FEerror("The block name ~S is undefined.", 1, Cnil); + Icall_error_handler(sKsimple_program_error, + make_simple_string("The block name ~S is undefined."), + 1, + Cnil); fr = frs_sch(MMcaddr(lex_block)); if (fr == NULL) - FEerror("The block ~S is missing.", 1, Cnil); + Icall_error_handler(sKsimple_program_error, + make_simple_string("The block ~S is missing."), + 1, + Cnil); if(endp(args)) { vs_base = vs_top; vs_push(Cnil); diff -uNr TEST.gcl/gcl/o/catch.c agcl/agcl/o/catch.c --- TEST.gcl/gcl/o/catch.c Sat Oct 26 18:18:13 2002 +++ agcl/agcl/o/catch.c Mon Nov 4 17:54:13 2002 @@ -80,7 +80,9 @@ lex_env = old_lex; {int i = fcall.nvalues; if (i+1>=sizeof(fcall.values)/sizeof(*fcall.values)) - FEerror("Too many function call values"); + Icall_error_handler(sLsimple_error, + make_simple_string("Too many function call values"), + 0); while (i > 0) { fcall.values[i+1] = fcall.values[i]; i--;} @@ -151,7 +153,10 @@ vs_push(tag); fr = frs_sch_catch(tag); if (fr == NULL) - FEerror("~S is an undefined tag.", 1, tag); + Icall_error_handler(sKsimple_control_error, + make_simple_string("~S is an undefined tag."), + 1, + tag); eval(MMcadr(args)); unwind(fr, tag); /* never reached */ diff -uNr TEST.gcl/gcl/o/cfun.c agcl/agcl/o/cfun.c --- TEST.gcl/gcl/o/cfun.c Tue Sep 24 21:01:45 2002 +++ agcl/agcl/o/cfun.c Mon Nov 4 17:54:13 2002 @@ -44,7 +44,9 @@ if(data && type_of(data)==t_cfdata) { data->cfd.cfd_start=start; data->cfd.cfd_size=size;} - else if(size) FEerror("Bad call to make_cfun",0); + else if(size) Icall_error_handler(sLsimple_error, + make_simple_string("Bad call to make_cfun"), + 0); return(cf); } object @@ -101,7 +103,9 @@ if(data && type_of(data)==t_cfdata) { data->cfd.cfd_start=start; data->cfd.cfd_size=size;} - else if(size) FEerror("Bad call to make_cclosure",0); + else if(size) Icall_error_handler(sLsimple_error, + make_simple_string("Bad call to make_cclosure"), + 0); return make_cclosure_new(self,name,env,data); } @@ -212,7 +216,9 @@ { if(data && type_of(data)==t_cfdata) { data->cfd.cfd_start=start; data->cfd.cfd_size=size;} - else if(size) FEerror("Bad call to make_cfun",0); + else if(size) Icall_error_handler(sLsimple_error, + make_simple_string("Bad call to make_cfun"), + 0); return(MFnew(sym,self,data)); } @@ -324,7 +330,10 @@ fun = fun->cf.cf_name; break; default: - FEerror("~S is not a compiled-function.", 1, fun); + Icall_error_handler(sLsimple_error, + make_simple_string("~S is not a compiled-function."), + 1, + fun); }RETURN1(fun); } diff -uNr TEST.gcl/gcl/o/character.d agcl/agcl/o/character.d --- TEST.gcl/gcl/o/character.d Sun Oct 6 05:07:22 2002 +++ agcl/agcl/o/character.d Mon Nov 4 17:54:13 2002 @@ -566,13 +566,19 @@ @(defun char_bit (c n) @ check_type_character(&c); - FEerror("Cannot get char-bit of ~S.", 1, c); + Icall_error_handler(sLsimple_error, + make_simple_string("Cannot get char-bit of ~S."), + 1, + c); @) @(defun set_char_bit (c n v) @ check_type_character(&c); - FEerror("Cannot set char-bit of ~S.", 1, c); + Icall_error_handler(sLsimple_error, + make_simple_string("Cannot set char-bit of ~S."), + 1, + c); @) void diff -uNr TEST.gcl/gcl/o/cmpaux.c agcl/agcl/o/cmpaux.c --- TEST.gcl/gcl/o/cmpaux.c Tue Jul 30 00:50:54 2002 +++ agcl/agcl/o/cmpaux.c Mon Nov 4 17:54:13 2002 @@ -83,7 +83,10 @@ { /* 2 args */ if(type_of(sSPmemory->s.s_dbind)==t_cfdata) sSPmemory->s.s_dbind->cfd.cfd_self[fix(index)]=val; - else FEerror("setvv called outside %init",0); + /* else FEerror("setvv called outside %init",0);*/ + else Icall_error_handler(sKsimple_storage_condition, + make_simple_string("SETVV called outside %INIT"), + 0); RETURN1(index); } @@ -106,7 +109,10 @@ ifloor(int x, int y) { if (y == 0) { - FEerror("Zero divizor", 0); + Icall_error_handler(sLdivision_by_zero, + make_simple_string("DIVISION operation with operands ~S is an error."), + 1, + make_cons((make_fixnum(x)),make_cons((make_fixnum(y)), Cnil))); return 0; } if (y > 0) { @@ -171,7 +177,10 @@ case t_character: c = char_code(x); break; default: - FEerror("~S cannot be coerce to a C char.", 1, x); + Icall_error_handler(sLsimple_error, + make_simple_string("~S cannot be coerced to a C char."), + 1, + x); } return(c); } @@ -196,7 +205,10 @@ case t_longfloat: i = lf(x); break; default: - FEerror("~S cannot be coerce to a C int.", 1, x); + Icall_error_handler(sLsimple_error, + make_simple_string("~S cannot be coerced to a C int."), + 1, + x); } return(i); } @@ -219,7 +231,10 @@ case t_longfloat: f = lf(x); break; default: - FEerror("~S cannot be coerce to a C float.", 1, x); + Icall_error_handler(sLsimple_error, + make_simple_string("~S cannot be coerced to a C float."), + 1, + x); } return(f); } @@ -242,7 +257,10 @@ case t_longfloat: d = lf(x); break; default: - FEerror("~S cannot be coerce to a C double.", 1, x); + Icall_error_handler(sLsimple_error, + make_simple_string("~S cannot be coerced to a C double."), + 1, + x); } return(d); } diff -uNr TEST.gcl/gcl/o/conditional.c agcl/agcl/o/conditional.c --- TEST.gcl/gcl/o/conditional.c Tue Sep 24 21:01:45 2002 +++ agcl/agcl/o/conditional.c Mon Nov 4 17:54:13 2002 @@ -66,7 +66,10 @@ while (!endp(args)) { clause = MMcar(args); if (type_of(clause) != t_cons) - FEerror("~S is an illegal COND clause.",1,clause); + Icall_error_handler(sLsimple_error, + make_simple_string("~S is an illegal COND clause."), + 1, + clause); eval(MMcar(clause)); if (vs_base[0] != Cnil) { conseq = MMcdr(clause); @@ -106,7 +109,10 @@ while (!endp(arg)) { clause = MMcar(arg); if (type_of(clause) != t_cons) - FEerror("~S is an illegal CASE clause.",1,clause); + Icall_error_handler(sLsimple_error, + make_simple_string("~S is an illegal CASE clause."), + 1, + clause); key = MMcar(clause); conseq = MMcdr(clause); if (type_of(key) == t_cons) diff -uNr TEST.gcl/gcl/o/error.c agcl/agcl/o/error.c --- TEST.gcl/gcl/o/error.c Wed Oct 16 05:24:02 2002 +++ agcl/agcl/o/error.c Sat Nov 9 13:16:34 2002 @@ -176,7 +176,7 @@ object b[F_ARG_LIMIT]; va_list ap; - b[0]=sKerror; + b[0]=sLsimple_error; b[1]=Cnil; b[2]=ihs_top_function_name(ihs_top-1); b[3]=null_string; @@ -250,7 +250,7 @@ object b[F_ARG_LIMIT]; va_list ap; - b[0]=sKerror; + b[0]=sLsimple_error; b[1]=Cnil; b[2]=ihs_top_function_name(ihs_top-1); b[3]=null_string; @@ -272,6 +272,7 @@ /* void */ /* FEerror(char *s, int num, object arg1, object arg2, object arg3, object arg4) */ +/* void FEerror(s,num,va_alist) char *s; @@ -306,18 +307,19 @@ fLerror(make_simple_string(s),arg1,arg2,arg3,arg4); } +*/ void FEwrong_type_argument(object type, object value) -{Icall_error_handler(sKwrong_type_argument, +{Icall_error_handler(sLtype_error, make_simple_string("~S is not of type ~S."), 2,(value),(type)); } void FEtoo_few_arguments(object *base, object *top) -{ Icall_error_handler(sKtoo_few_arguments, +{ Icall_error_handler(sKsimple_program_error, (make_simple_string("~S [or a callee] requires more than ~R argument~:p.")), 2,(ihs_top_function_name(ihs_top)), (make_fixnum(top - base))); @@ -326,7 +328,7 @@ void FEtoo_few_argumentsF(object args) -{Icall_error_handler(sKtoo_few_arguments, +{Icall_error_handler(sKsimple_program_error, make_simple_string("Too few arguments."), 2,(ihs_top_function_name(ihs_top)), (args)); @@ -334,7 +336,7 @@ void FEtoo_many_arguments(object *base, object *top) -{ Icall_error_handler(sKtoo_many_arguments, +{ Icall_error_handler(sKsimple_program_error, (make_simple_string("~S [or a callee] requires less than ~R argument~:p.")), 2,(ihs_top_function_name(ihs_top)),(make_fixnum(top - base))); } @@ -342,13 +344,13 @@ void FEtoo_many_argumentsF(object args) { - Icall_error_handler(sKtoo_many_arguments, + Icall_error_handler(sKsimple_program_error, make_simple_string("Too many arguments."),0); } void FEinvalid_macro_call(void) -{Icall_error_handler(sKinvalid_form, +{Icall_error_handler(sKsimple_program_error, (make_simple_string("Invalid macro call to ~S.")), 1,(ihs_top_function_name(ihs_top))); } @@ -358,7 +360,7 @@ {/* if (!keywordp(key)) */ /* not_a_keyword(key); */ - Icall_error_handler(sKunexpected_keyword, + Icall_error_handler(sKsimple_program_error, make_simple_string("~S does not allow the keyword ~S."), 2,(ihs_top_function_name(ihs_top)),(key)); @@ -366,34 +368,37 @@ void FEinvalid_form(char *s, object form) -{Icall_error_handler(sKinvalid_form,make_simple_string(s), +{Icall_error_handler(sKsimple_program_error, + make_simple_string(s), 1,(form)); } void FEunbound_variable(object sym) -{Icall_error_handler(sKunbound_variable, +{Icall_error_handler(sLunbound_variable, make_simple_string("The variable ~S is unbound."), 1,(sym)); } void FEinvalid_variable(char *s, object obj) -{Icall_error_handler(sKinvalid_variable,make_simple_string(s), - 1,(obj)); +{Icall_error_handler(sKsimple_program_error, + make_simple_string(s), + 1, + (obj)); } void FEundefined_function(object fname) -{Icall_error_handler(sKundefined_function, +{Icall_error_handler(sLundefined_function, make_simple_string("The function ~S is undefined."), 1,(fname)); } void FEinvalid_function(object obj) -{Icall_error_handler(sKinvalid_function, +{Icall_error_handler(sKsimple_program_error, make_simple_string("~S is invalid as a function."), 1,(obj)); @@ -402,9 +407,11 @@ void FEpackage_error(object obj,const char *s) { - Icall_continue_error_handler(sKpackage_error, - make_simple_string("A package error occurred on ~S: ~S."), - 2,(obj),make_simple_string(s)); + Icall_error_handler(sKsimple_package_error, + make_simple_string(s), + 1, + obj); + } @@ -433,7 +440,10 @@ if (ihs_org <= p && p <= ihs_top) return(p); ILLEGAL: - FEerror("~S is an illegal ihs index.", 1, x); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal ihs index."), + 1, + x); return(NULL); } @@ -474,7 +484,10 @@ if (frs_org <= p && p <= frs_top) return(p); ILLEGAL: - FEerror("~S is an illegal frs index.", 1, x); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal frs index."), + 1, + x); return NULL; } @@ -517,7 +530,9 @@ 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); + else Icall_error_handler(sLsimple_type_error, + make_simple_string("Unknown frs class was detected."), + 0); RETURN1(x0); } @@ -551,7 +566,10 @@ if (bds_org <= p && p <= bds_top) return(p); ILLEGAL: - FEerror("~S is an illegal bds index.", 1, x); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal bds index."), + 1, + x); return NULL; } @@ -591,7 +609,10 @@ if (vs_org <= p && p < vs_top) return(p); ILLEGAL: - FEerror("~S is an illegal vs index.", 1, x); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal vs index."), + 1, + x); return NULL; } @@ -641,7 +662,10 @@ fr = frs_sch(tag); if (fr == NULL) - FEerror("The tag ~S is missing.", 1, tag); + Icall_error_handler(sKsimple_control_error, + make_simple_string("The tag ~S is missing."), + 1, + tag); if (x2 == Cnil) tag = x1; else @@ -695,15 +719,21 @@ ck_larg_at_least(int n, object x) { for(; n > 0; n--, x = x->c.c_cdr) if(endp(x)) - FEerror("APPLY sent too few arguments to LAMBDA.", 0); + Icall_error_handler(sKsimple_program_error, + make_simple_string("APPLY sent too few arguments to LAMBDA."), + 0); } void ck_larg_exactly(int n, object x) { for(; n > 0; n--, x = x->c.c_cdr) if(endp(x)) - FEerror("APPLY sent too few arguments to LAMBDA.", 0); - if(!endp(x)) FEerror("APPLY sent too many arguments to LAMBDA.", 0); + Icall_error_handler(sKsimple_program_error, + make_simple_string("APPLY sent too few arguments to LAMBDA."), + 0); + if(!endp(x)) Icall_error_handler(sKsimple_program_error, + make_simple_string("APPLY sent too many arguments to LAMBDA."), + 0); } void @@ -715,7 +745,9 @@ void keyword_value_mismatch(void) { - FEerror("Keywords and values do not match.", 0); + Icall_error_handler(sKsimple_program_error, + make_simple_string("Keywords and values do not match."), + 0); } void @@ -752,7 +784,10 @@ void not_a_string_or_symbol(object x) { - FEerror("~S is not a string or symbol.", 1, x); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is not a string or symbol."), + 1, + x); } void @@ -771,7 +806,11 @@ void illegal_index(object x, object i) { - FEerror("~S is an illegal index to ~S.", 2, i, x); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal index to ~S."), + 2, + i, + x); } void @@ -805,8 +844,11 @@ vfun_wrong_number_of_args(object x) { - FEerror("Expected ~S args but received ~S args",2, - x,make_fixnum(VFUN_NARGS)); + Icall_error_handler(sKsimple_program_error, + make_simple_string("Expected ~S args but received ~S args"), + 2, + x, + make_fixnum(VFUN_NARGS)); } @@ -839,6 +881,45 @@ DEF_ORDINARY("CATCH",sKcatch,KEYWORD,""); DEF_ORDINARY("PROTECT",sKprotect,KEYWORD,""); DEF_ORDINARY("CATCHALL",sKcatchall,KEYWORD,""); + +DEF_ORDINARY("ARITHMETIC-ERROR",sLarithmetic_error,LISP,""); +DEF_ORDINARY("CELL-ERROR",sLcell_error,LISP,""); + DEF_ORDINARY("CONDITION",sLcondition,LISP,""); +DEF_ORDINARY("CONTROL-ERROR",sLcontrol_error,LISP,""); +DEF_ORDINARY("DIVISION-BY-ZERO",sLdivision_by_zero,LISP,""); +DEF_ORDINARY("END-OF-FILE",sLend_of_file,LISP,""); +DEF_ORDINARY("ERROR",sLerror,LISP,""); +DEF_ORDINARY("FILE-ERROR",sLfile_error,LISP,""); +DEF_ORDINARY("FLOATING-POINT-INEXACT",sLfloating_point_inexact,LISP,""); +DEF_ORDINARY("FLOATING-POINT-INVALID-OPERATION",sLfloating_point_invalid_operation,LISP,""); +DEF_ORDINARY("FLOATING-POINT-OVERFLOW",sLfloating_point_overflow,LISP,""); +DEF_ORDINARY("FLOATING-POINT-UNDERFLOW",sLfloating_point_underflow,LISP,""); +DEF_ORDINARY("PACKAGE-ERROR",sLpackage_error,LISP,""); +DEF_ORDINARY("PARSE-ERROR",sLparse_error,LISP,""); +DEF_ORDINARY("PRINT-NOT-READABLE",sLprint_not_readable,LISP,""); +DEF_ORDINARY("PROGRAM-ERROR",sLprogram_error,LISP,""); +DEF_ORDINARY("READER-ERROR",sLreader_error,LISP,""); +DEF_ORDINARY("SERIOUS-CONDITION",sLserious_condition,LISP,""); +DEF_ORDINARY("SIMPLE-CONDITION",sLsimple_condition,LISP,""); +DEF_ORDINARY("SIMPLE-ERROR",sLsimple_error,LISP,""); +DEF_ORDINARY("SIMPLE-TYPE-ERROR",sLsimple_type_error,LISP,""); +DEF_ORDINARY("SIMPLE-WARNING",sLsimple_warning,LISP,""); +DEF_ORDINARY("STORAGE-CONDITION",sLstorage_condition,LISP,""); +DEF_ORDINARY("STREAM-ERROR",sLstream_error,LISP,""); +DEF_ORDINARY("STYLE-WARNING",sLstyle_warning,LISP,""); +DEF_ORDINARY("TYPE-ERROR",sLtype_error,LISP,""); +DEF_ORDINARY("UNBOUND-SLOT",sLunbound_slot,LISP,""); +DEF_ORDINARY("UNBOUND-VARIABLE",sLunbound_variable,LISP,""); +DEF_ORDINARY("UNDEFINED-FUNCTION",sLundefined_function,LISP,""); +DEF_ORDINARY("WARNING",sLwarning,LISP,""); + +DEF_ORDINARY("SIMPLE-STORAGE-CONDITION",sKsimple_storage_condition,KEYWORD,""); +DEF_ORDINARY("SIMPLE-PROGRAM-ERROR",sKsimple_program_error,KEYWORD,""); +DEF_ORDINARY("SIMPLE-CONTROL-ERROR",sKsimple_control_error,KEYWORD,""); +DEF_ORDINARY("SIMPLE-READER-ERROR",sKsimple_reader_error,KEYWORD,""); +DEF_ORDINARY("SIMPLE-PACKAGE-ERROR",sKsimple_package_error,KEYWORD,""); +DEF_ORDINARY("SIMPLE-FP-OVERFLOW",sKsimple_fp_overflow,KEYWORD,""); +DEF_ORDINARY("SIMPLE-PARSE-ERROR",sKsimple_parse_error,KEYWORD,""); void diff -uNr TEST.gcl/gcl/o/eval.c agcl/agcl/o/eval.c --- TEST.gcl/gcl/o/eval.c Tue Sep 24 21:01:45 2002 +++ agcl/agcl/o/eval.c Mon Nov 4 17:54:13 2002 @@ -114,7 +114,9 @@ base[0]= (restype==f_object ? res : restype==f_fixnum ? make_fixnum((long)res) - :(object) (FEerror("Bad result type",0),Cnil)); + :(object) (Icall_error_handler(sLsimple_type_error, + make_simple_string("Bad result type"), + 0),Cnil)); vs_base = base; vs_top=base+1; CHECK_AVMA; @@ -163,7 +165,10 @@ DEBUG_AVMA TOP: if (fun == OBJNULL) - FEerror("Undefined function.", 0); + Icall_error_handler(sLundefined_function, + make_simple_string("Undefined function: ~A"), + 1, + fun); switch (type_of(fun)) { case t_cfun: MMcall(fun); @@ -341,7 +346,10 @@ { DEBUG_AVMA if (fun == OBJNULL) - FEerror("Undefined function.", 0); + Icall_error_handler(sLundefined_function, + make_simple_string("Undefined function: ~A"), + 1, + fun); switch (type_of(fun)) { case t_cfun: (*fun->cf.cf_self)(); @@ -389,7 +397,10 @@ vs_top = vs_base + narg; if (fun == OBJNULL) - FEerror("Undefined function.", 0); + Icall_error_handler(sLundefined_function, + make_simple_string("Undefined function: ~A"), + 1, + fun); switch (type_of(fun)) { case t_cfun: MMcall(fun); @@ -431,7 +442,10 @@ vs_top = vs_base + narg; if (fun == OBJNULL) - FEerror("Undefined function.", 0); + Icall_error_handler(sLundefined_function, + make_simple_string("Undefined function: ~A"), + 1, + fun); switch (type_of(fun)) { case t_cfun: (*fun->cf.cf_self)(); @@ -474,7 +488,10 @@ vs_top = vs_base + narg; if (fun == OBJNULL) - FEerror("Undefined function.", 0); + Icall_error_handler(sLundefined_function, + make_simple_string("Undefined function: ~A"), + 1, + fun); switch (type_of(fun)) { case t_cfun: MMcall(fun); @@ -515,7 +532,10 @@ vs_top = vs_base + narg; if (fun == OBJNULL) - FEerror("Undefined function.", 0); + Icall_error_handler(sLundefined_function, + make_simple_string("Undefined function: ~A"), + 1, + fun); switch (type_of(fun)) { case t_cfun: (*fun->cf.cf_self)(); @@ -558,7 +578,10 @@ vs_top = vs_base + narg; if (fun == OBJNULL) - FEerror("Undefined function.", 0); + Icall_error_handler(sLundefined_function, + make_simple_string("Undefined function: ~A"), + 1, + fun); switch (type_of(fun)) { case t_cfun: MMcall(fun); @@ -603,7 +626,10 @@ vs_top = vs_base + narg; if (fun == OBJNULL) - FEerror("Undefined function.", 0); + Icall_error_handler(sLundefined_function, + make_simple_string("Undefined function: ~A"), + 1, + fun); switch (type_of(fun)) { case t_cfun: (*fun->cf.cf_self)(); @@ -648,7 +674,10 @@ vs_top = vs_base + narg; if (fun == OBJNULL) - FEerror("Undefined function.", 0); + Icall_error_handler(sLundefined_function, + make_simple_string("Undefined function: ~A"), + 1, + fun); switch (type_of(fun)) { case t_cfun: MMcall(fun); @@ -693,7 +722,10 @@ vs_top = vs_base + narg; if (fun == OBJNULL) - FEerror("Undefined function.", 0); + Icall_error_handler(sLundefined_function, + make_simple_string("Undefined function: ~A"), + 1, + fun); switch (type_of(fun)) { case t_cfun: (*fun->cf.cf_self)(); @@ -1159,7 +1191,10 @@ list = va_arg(ap,object); va_end(ap); while (!endp(list)) - { if (m >= MAX_ARGS) FEerror(" Lisps arglist maximum surpassed",0); + { if (m >= MAX_ARGS) + Icall_error_handler(sLsimple_error, + make_simple_string(" GCL's arglist maximum surpassed"), + 0); *base++ = Mcar(list); list = Mcdr(list); m++;} @@ -1377,7 +1412,9 @@ case 1: *(base++)=va_arg(ap,object); case 0: break; default: - FEerror("bad args",0); + Icall_error_handler(sLsimple_error, + make_simple_string("bad args"), + 0); } vs_top=base; base=base -i; do{object fun=fcall.fun; @@ -1420,7 +1457,9 @@ x = (typ==f_object ? va_arg(ap,object): typ==f_fixnum ? make_fixnum(va_arg(ap,fixnum)): - (object) (FEerror("bad type",0),Cnil)); + (object) (Icall_error_handler(sLsimple_error, + make_simple_string("bad type"), + 0),Cnil)); *(vs_top++) = x; } else { @@ -1435,7 +1474,9 @@ /* vs_base=old_vs_base; */ return (restype== f_object ? x : restype== f_fixnum ? (object) (fix(x)): - (object) (FEerror("bad type",0),Cnil)); + (object) (Icall_error_handler(sLsimple_error, + make_simple_string("bad type"), + 0),Cnil)); } } @@ -1474,7 +1515,9 @@ case 1: *(base++)=va_arg(ap,object); case 0: break; default: - FEerror("bad args",0); + Icall_error_handler(sLsimple_error, + make_simple_string("bad args"), + 0); } vs_top=base; base=base -i; (*fcall.fun->cf.cf_self)(); diff -uNr TEST.gcl/gcl/o/external_funs.h agcl/agcl/o/external_funs.h --- TEST.gcl/gcl/o/external_funs.h Mon Dec 6 23:44:10 1999 +++ agcl/agcl/o/external_funs.h Mon Nov 4 17:54:13 2002 @@ -330,7 +330,7 @@ extern object ihs_function_name GPR((object x));; extern object ihs_top_function_name GPR((void));; extern int call_error_handler GPR((void));; -extern int FEerror GPR((char *s, int num, object arg1, object arg2, object arg3, object arg4));; +/*extern int FEerror GPR((char *s, int num, object arg1, object arg2, object arg3, object arg4));; */ extern int FEwrong_type_argument GPR((object type, object value));; extern int FEtoo_few_arguments GPR((object *base, object *top));; extern int FEtoo_few_argumentsF GPR((object args));; diff -uNr TEST.gcl/gcl/o/fasdump.c agcl/agcl/o/fasdump.c --- TEST.gcl/gcl/o/fasdump.c Tue Sep 10 05:35:15 2002 +++ agcl/agcl/o/fasdump.c Mon Nov 4 17:54:13 2002 @@ -499,7 +499,9 @@ return LATER_INDEX; } else - FEerror("too large an index",0); + Icall_error_handler(sLsimple_error, + make_simple_string("too large an index"), + 0); return LATER_INDEX; } @@ -509,7 +511,9 @@ {struct fasd *fd = (struct fasd *) x->v.v_self; if (fd->direction == sKoutput) SETUP_FASD_IN(fd); - else FEerror("bad value for open slot of fasd",0); + else Icall_error_handler(sLsimple_error, + make_simple_string("bad value for open slot of fasd"), + 0); write_fasd(obj); /* we could really allocate a fixnum and then smash its field if this @@ -551,7 +555,9 @@ else if(current_fasd.direction== Cnil) result= current_fasd.eof; else - FEerror("Stream not open for input",0); + Icall_error_handler(sLsimple_error, + make_simple_string("Stream not open for input"), + 0); L: frs_pop(); @@ -615,7 +621,9 @@ else /* input */ { object tem; read_fasd1(GET_OP(),&tem); - if(tem!=current_fasd.table) FEerror("not positioned at beginning of a dump",0); + if(tem!=current_fasd.table) Icall_error_handler(sLsimple_error, + make_simple_string("not positioned at beginning of a dump"), + 0); } fd->index=make_fixnum(dump_index); fd->filepos=current_fasd.filepos; @@ -831,7 +839,10 @@ int i; object name= S_DATA(obj->str.str_def)->name; if(narg >= SHORT_MAX) - FEerror("Only dump structures whose length < ~a",1,make_fixnum(SHORT_MAX)); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Only dump structures whose length < ~A."), + 1, + make_fixnum(SHORT_MAX)); PUT_OP(d_structure); PUTD("narg=%d",narg); write_fasd(name); @@ -910,7 +921,9 @@ switch (type_of(x)) { case DP(t_spice:) { if (x->spc.spc_dummy >= current_fasd.table->v.v_dim) - FEerror("bad spice ref",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("bad spice ref"), + 0); return current_fasd.table->v.v_self[x->spc.spc_dummy ]; } @@ -1101,7 +1114,9 @@ static void bad_eof(void) -{ FEerror("Unexpected end of file",0);} +{ Icall_error_handler(sLend_of_file, + make_simple_string("Unexpected end of file"), + 0);} @@ -1154,7 +1169,9 @@ case DP(d_delimiter:) case DP(d_dot:) - FEerror("Illegal op at top level",0); + Icall_error_handler(sLsimple_error, + make_simple_string("Illegal op at top level"), + 0); break; case DP(d_eval_skip:) read_fasd1(GET_OP(),loc); @@ -1168,7 +1185,9 @@ case d_reserve3: case d_reserve4: - FEerror("Op reserved for future use",0); + Icall_error_handler(sLsimple_error, + make_simple_string("Op reserved for future use"), + 0); break; case DP(d_reset_index:) @@ -1336,7 +1355,10 @@ {object pack,tem; read_fasd1(GET_OP(),&tem); pack=find_package(tem); - if (pack==Cnil) FEerror("The package named ~a, does not exist",1,tem); + if (pack==Cnil) Icall_error_handler(sLpackage_error, + make_simple_string("The package named ~a, does not exist."), + 1, + tem); *loc=pack; return ;} case DP(d_standard_character:) @@ -1396,8 +1418,11 @@ case DP(d_begin_dump:) {int vers=GETD("version=%d"); if(vers!=FASD_VERSION) - FEerror("This file was dumped with FASD version ~a not ~a.", - 2,make_fixnum(vers),make_fixnum(FASD_VERSION));} + Icall_error_handler(sLsimple_error, + make_simple_string("This file was dumped with FASD version ~a not ~a."), + 2, + make_fixnum(vers), + make_fixnum(FASD_VERSION));} {int leng; GET4(leng); current_fasd.table_length=make_fixnum(leng);} @@ -1405,12 +1430,16 @@ if (type_of(tem)==t_package || tem==Cnil) {current_fasd.package = tem; *loc=current_fasd.table;} - else FEerror("expected package",0); + else Icall_error_handler(sLsimple_type_error, + make_simple_string("expected package"), + 0); return; case DP(d_general_type:) *loc=read_object_non_recursive(current_fasd.stream); - if(GETD("close general:%c")!=')') FEerror("general type not followed by ')'",0); + if(GETD("close general:%c")!=')') Icall_error_handler(sKsimple_reader_error, + make_simple_string("general type not followed by ')'"), + 0); return; @@ -1426,7 +1455,9 @@ object vv = sSPmemory->s.s_dbind,tem; if (vv == Cnil) print_only = 1; else - if (type_of(vv)!=t_cfdata) FEerror("bad VectorToEnter",0); + if (type_of(vv)!=t_cfdata) Icall_error_handler(sLsimple_type_error, + make_simple_string("bad VectorToEnter"), + 0); while ((i=GET_OP()) !=d_delimiter) {int eval=(i==d_eval_skip); if (print_only) @@ -1448,7 +1479,9 @@ if(eval) lisp_eval(tem); else - {if (n >= vv->cfd.cfd_fillp) FEerror("cfd too small",0); + {if (n >= vv->cfd.cfd_fillp) Icall_error_handler(sLsimple_type_error, + make_simple_string("cfd too small"), + 0); vv->cfd.cfd_self[n++]=tem;}}} if (print_only==0) vv->cfd.cfd_fillp = n; *loc=vv; @@ -1495,7 +1528,10 @@ d = coerce_to_namestring(d); in = open_stream(d,smm_input,Cnil,Cnil); if (in == Cnil) - FEerror("Can't open file ~s",1,d); + Icall_error_handler(sLfile_error, + make_simple_string("Can't open file ~s"), + 1, + d); } else if (tem != EOF) { ungetc(tem,in->sm.sm_fp);} @@ -1533,7 +1569,10 @@ if (orig != in) close_stream(in); return result; - ERROR: FEerror("Bad fasd stream ~a",1,in); + ERROR: Icall_error_handler(sLstream_error, + make_simple_string("Bad fasd stream ~a"), + 1, + in); return Cnil; }} diff -uNr TEST.gcl/gcl/o/fat_string.c agcl/agcl/o/fat_string.c --- TEST.gcl/gcl/o/fat_string.c Tue Sep 24 05:08:33 2002 +++ agcl/agcl/o/fat_string.c Mon Nov 4 17:54:13 2002 @@ -46,10 +46,13 @@ object ar=sSAprofile_arrayA->s.s_dbind; if (type_of(ar)!=t_string) - FEerror("si:*Profile-array* not a string",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("si:*Profile-array* not a string"), + 0); if( type_of(start_address)!=t_fixnum || type_of(scale)!=t_fixnum) - FEerror("Needs start address and scale as args",0); - + Icall_error_handler(sLsimple_error, + make_simple_string("Needs start address and scale as args"), + 0); profil((void *) (ar->ust.ust_self), (ar->ust.ust_dim), fix(start_address),fix(scale) << 8); RETURN1(start_address); @@ -65,7 +68,9 @@ && type_of(funobj)!=t_vfun && type_of(funobj)!=t_afun && type_of(funobj)!=t_gfun) - FEerror("not compiled function",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Not compiled function"), + 0); funobj=make_fixnum((long) (funobj->cf.cf_self)); RETURN1(funobj); } @@ -98,7 +103,9 @@ if (!(symin=fopen(symfile,"r"))) {perror(symfile);exit(1);}; if(!fread((char *)&tab,sizeof(tab),1,symin)) - FEerror("No header",0); + Icall_error_handler(sLsimple_error, + make_simple_string("No header"), + 0); symbols=malloc(tab.tot_leng); c_table.alloc_length=( (PTABLE_EXTRA+ tab.n_symbols)); (c_table.ptable) = (TABL *) malloc(sizeof(struct node) * c_table.alloc_length); @@ -177,7 +184,9 @@ (combined_table.ptable)=NULL; (combined_table.ptable)= (TABL *)malloc(n* sizeof(struct node)); if(!combined_table.ptable) - FEerror("unable to allocate",0); + Icall_error_handler(sKsimple_storage_condition, + make_simple_string("Unable to allocate."), + 0); combined_table.alloc_length=n;} for (i = 0; i < maxpage; i++) { @@ -206,7 +215,9 @@ /* (x->cf.cf_name ? x->cf.cf_name->s.st_self : NULL) ; */ combined_table.length = ++ii; if (ii >= combined_table.alloc_length) - FEerror("Need a larger combined_table",0); + Icall_error_handler(sLsimple_error, + make_simple_string("Need a larger combined_table"), + 0); } } @@ -235,7 +246,9 @@ return true; if (!h->u.def.section) { - FEerror("Symbol without section"); + Icall_error_handler(sLsimple_error, + make_simple_string("Symbol without section"), + 0); return false; } @@ -344,7 +357,9 @@ ,2,2,NONE,OO,OO,OO,OO,siLdisplay_profile,"")(start_addr,scal) object start_addr,scal; {if (!combined_table.ptable) - FEerror("must symbols first",0); + Icall_error_handler(sLsimple_error, + make_simple_string("Symbols first!"), + 0); /* 2 args */ {unsigned int prev,next,upto,dim,total; int j,scale,count; @@ -352,7 +367,9 @@ object obj_ar; obj_ar=sSAprofile_arrayA->s.s_dbind; if (type_of(obj_ar)!=t_string) - FEerror("si:*Profile-array* not a string",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("si:*Profile-array* not a string"), + 0); ar=obj_ar->ust.ust_self; scale=fix(scal); prof_start=fix(start_addr); diff -uNr TEST.gcl/gcl/o/file.d agcl/agcl/o/file.d --- TEST.gcl/gcl/o/file.d Fri Nov 1 05:09:34 2002 +++ agcl/agcl/o/file.d Mon Nov 4 17:54:13 2002 @@ -116,7 +116,10 @@ end_of_stream(strm) object strm; { - FEerror("Unexpected end of ~S.", 1, strm); + Icall_error_handler(sLstream_error, + make_simple_string("Unexpected end of ~S."), + 1, + strm); } /* @@ -400,8 +403,10 @@ } else if (if_does_not_exist == Cnil) return(Cnil); else - FEerror("~S is an illegal IF-DOES-NOT-EXIST option.", - 1, if_does_not_exist); + Icall_error_handler(sLsimple_error, + make_simple_string("~S is an illegal IF-DOES-NOT-EXIST option."), + 1, + if_does_not_exist); } } else if (smm == smm_output || smm == smm_io) { if (if_exists == sKnew_version && if_does_not_exist == sKcreate) @@ -410,7 +415,10 @@ if (fp != NULL) { fclose(fp); if (if_exists == sKerror) - FEerror("The file ~A already exists.", 1, fn); + Icall_error_handler(sLfile_error, + make_simple_string("The file ~A already exists."), + 1, + fn); else if (if_exists == sKrename) { if (smm == smm_output) fp = backup_fopen(fname, "w"); @@ -437,15 +445,23 @@ else fp = fopen(fname, "a+"); if (fp == NULL) - FEerror("Cannot append to the file ~A.",1,fn); + Icall_error_handler(sLfile_error, + make_simple_string("Cannot append to the file ~A."), + 1, + fn); } else if (if_exists == Cnil) return(Cnil); else - FEerror("~S is an illegal IF-EXISTS option.", - 1, if_exists); + Icall_error_handler(sLsimple_error, + make_simple_string("~S is an illegal IF-EXISTS option."), + 1, + if_exists); } else { if (if_does_not_exist == sKerror) - FEerror("The file ~A does not exist.", 1, fn); + Icall_error_handler(sLfile_error, + make_simple_string("The file ~A does not exist."), + 1, + fn); else if (if_does_not_exist == sKcreate) { CREATE: if (smm == smm_output) @@ -462,8 +478,10 @@ } else if (if_does_not_exist == Cnil) return(Cnil); else - FEerror("~S is an illegal IF-DOES-NOT-EXIST option.", - 1, if_does_not_exist); + Icall_error_handler(sLsimple_error, + make_simple_string("~S is an illegal IF-DOES-NOT-EXIST option."), + 1, + if_does_not_exist); } } else error("illegal stream mode"); @@ -498,7 +516,10 @@ switch (strm->sm.sm_mode) { case smm_output: if (strm->sm.sm_fp == stdout) - FEerror("Cannot close the standard output.", 0); + Icall_error_handler(sLstream_error, + make_simple_string("Cannot close ~S."), + 1, + strm); if (strm->sm.sm_fp == NULL) break; fflush(strm->sm.sm_fp); deallocate_stream_buffer(strm); @@ -526,7 +547,10 @@ case smm_input: if (strm->sm.sm_fp == stdin) - FEerror("Cannot close the standard input.", 0); + Icall_error_handler(sLstream_error, + make_simple_string("Cannot close ~S."), + 1, + strm); case smm_io: case smm_probe: @@ -856,7 +880,10 @@ return; UNREAD_ERROR: - FEerror("Cannot unread the stream ~S.", 1, strm); + Icall_error_handler(sLstream_error, + make_simple_string("Cannot unread the stream ~S."), + 1, + strm); } void @@ -939,8 +966,10 @@ x = STRING_STREAM_STRING(strm); if (x->st.st_fillp >= x->st.st_dim) { if (!x->st.st_adjustable) - FEerror("The string ~S is not adjustable.", - 1, x); + Icall_error_handler(sLsimple_error, + make_simple_string("The string ~S is not adjustable."), + 1, + x); p = (inheap((long)x->st.st_dim) ? alloc_contblock : alloc_relblock) (x->st.st_dim * 2 + 16); for (i = 0; i < x->st.st_dim; i++) @@ -948,7 +977,9 @@ i = x->st.st_dim * 2 + 16; #define ADIMLIM 16*1024*1024 if (i >= ADIMLIM) - FEerror("Can't extend the string.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Can't extend the string."), + 0); x->st.st_dim = i; adjust_displaced(x, p - x->st.st_self); } @@ -1034,7 +1065,10 @@ case smm_probe: case smm_concatenated: case smm_string_input: - FEerror("Cannot flush the stream ~S.", 1, strm); + Icall_error_handler(sLstream_error, + make_simple_string("Cannot flush the stream ~S."), + 1, + strm); #ifdef USER_DEFINED_STREAMS case smm_user_defined: {object *old_vs_base = vs_base; @@ -1233,7 +1267,10 @@ case smm_probe: case smm_broadcast: case smm_string_output: - FEerror("Can't listen to ~S.", 1, strm); + Icall_error_handler(sLstream_error, + make_simple_string("Can't listen to ~S."), + 1, + strm); return(FALSE); default: error("illegal stream mode"); @@ -1561,9 +1598,13 @@ @(return `make_string_input_stream(strng, s, e)`) E: - FEerror("~S and ~S are illegal as :START and :END~%\ -for the string ~S.", - 3, istart, iend, strng); + Icall_error_handler(sLsimple_error, + make_simple_string("~S and ~S are illegal as :START and :END~%\ + for the string ~S."), + 3, + istart, + iend, + strng); @) void @@ -1580,7 +1621,10 @@ if (type_of(vs_base[0]) != t_stream || (enum smmode)vs_base[0]->sm.sm_mode != smm_string_output) - FEerror("~S is not a string-output stream.", 1, vs_base[0]); + Icall_error_handler(sLstream_error, + make_simple_string("~S is not a string-output stream."), + 1, + vs_base[0]); vs_base[0] = get_output_stream_string(vs_base[0]); } @@ -1596,7 +1640,10 @@ check_arg(1); if (type_of(vs_base[0]) != t_stream || (enum smmode)vs_base[0]->sm.sm_mode != smm_string_output) - FEerror("~S is not a string-output stream.", 1, vs_base[0]); + Icall_error_handler(sLstream_error, + make_simple_string("~S is not a string-output stream."), + 1, + vs_base[0]); vs_base[0] = vs_base[0]->sm.sm_object0; } @@ -1692,8 +1739,10 @@ if (!idnesp) if_does_not_exist = Cnil; } else - FEerror("~S is an illegal DIRECTION for OPEN.", - 1, direction); + Icall_error_handler(sLsimple_error, + make_simple_string("~S is an illegal DIRECTION for OPEN."), + 1, + direction); strm = open_stream(filename, smm, if_exists, if_does_not_exist); @(return strm) @) @@ -1714,9 +1763,12 @@ i = file_length(file_stream); else if (type_of(position) != t_fixnum || (i = fix((position))) < 0) - FEerror("~S is an illegal file position~%\ -for the file-stream ~S.", - 2, position, file_stream); + Icall_error_handler(sLsimple_error, + make_simple_string("~S is an illegal file position~%\ + for the file-stream ~S."), + 2, + position, + file_stream); if (file_position_set(file_stream, i) < 0) @(return Cnil) @(return Ct) @@ -1901,7 +1953,10 @@ check_arg(1); check_type_stream(&vs_base[0]); if ((enum smmode)vs_base[0]->sm.sm_mode != smm_string_input) - FEerror("~S is not a string-input stream.", 1, vs_base[0]); + Icall_error_handler(sLstream_error, + make_simple_string("~S is not a string-input stream."), + 1, + vs_base[0]); vs_base[0] = make_fixnum(STRING_INPUT_STREAM_NEXT(vs_base[0])); } @@ -1913,7 +1968,10 @@ check_arg(1); strng = vs_base[0]; if (type_of(strng) != t_string || !strng->st.st_hasfillp) - FEerror("~S is not a string with a fill-pointer.", 1, strng); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is not a string with a fill-pointer."), + 1, + strng); strm = alloc_object(t_stream); strm->sm.sm_mode = (short)smm_string_output; strm->sm.sm_fp = NULL; @@ -1948,35 +2006,50 @@ too_long_file_name(fn) object fn; { - FEerror("~S is a too long file name.", 1, fn); + Icall_error_handler(sLsimple_error, + make_simple_string("~S is a too long file name."), + 1, + fn); } void cannot_open(fn) object fn; { - FEerror("Cannot open the file ~A.", 1, fn); + Icall_error_handler(sLfile_error, + make_simple_string("Cannot open the file ~A."), + 1, + fn); } void cannot_create(fn) object fn; { - FEerror("Cannot create the file ~A.", 1, fn); + Icall_error_handler(sLfile_error, + make_simple_string("Cannot create the file ~A."), + 1, + fn); } void cannot_read(strm) object strm; { - FEerror("Cannot read the stream ~S.", 1, strm); + Icall_error_handler(sLstream_error, + make_simple_string("Cannot read the stream ~S."), + 1, + strm); } void cannot_write(strm) object strm; { - FEerror("Cannot write to the stream ~S.", 1, strm); + Icall_error_handler(sLstream_error, + make_simple_string("Cannot write to the stream ~S."), + 1, + strm); } #ifdef USER_DEFINED_STREAMS @@ -1989,7 +2062,10 @@ if(vs_base[0]->sm.sm_object1) vs_base[0] = vs_base[0]->sm.sm_object1->str.str_self[0]; else - FEerror("sLtream data NULL ~S", 1, vs_base[0]); + Icall_error_handler(sLstream_error, + make_simple_string("Stream data NULL: ~S."), + 1, + vs_base[0]); } #endif @@ -2000,7 +2076,10 @@ if (!GET_STREAM_FLAG(strm,gcl_sm_had_error)) { SET_STREAM_FLAG(strm,gcl_sm_had_error,1); - FEerror("The stream ~S is already closed.", 1, strm); + Icall_error_handler(sLstream_error, + make_simple_string("The stream ~S is already closed."), + 1, + strm); } } @@ -2160,7 +2239,10 @@ if (wrote < 0) { SET_STREAM_FLAG(strm,gcl_sm_had_error,1); close_stream(strm); - FEerror("error writing to socket: errno= ~a",1,make_fixnum(err)); + Icall_error_handler(sLsimple_error, + make_simple_string("Error writing to socket: errno= ~A."), + 1, + make_fixnum(err)); } i+= wrote; @@ -2181,7 +2263,9 @@ object x; if (fd < 0 ) { - FEerror("Could not connect",0); + Icall_error_handler(sLsimple_error, + make_simple_string("Could not connect"), + 0); } x = alloc_object(t_stream); x->sm.sm_mode = smm_socket; @@ -2196,7 +2280,9 @@ /* if (mode == gcl_sm_output) { fp=fdopen(fd,(mode==gcl_sm_input ? "r" : "w")); - if (fp==NULL) FEerror("Could not connect",0); + if (fp==NULL) Icall_error_handler(sLsimple_error, + make_simple_string("Could not connect"), + 0); x->sm.sm_fp = fp; setup_stream_buffer(x); } else @@ -2243,7 +2329,9 @@ myaddrPtr=lisp_copy_to_null_terminated(myaddr,myaddrPtr,sizeof(buf2)); } else { myaddrPtr = NULL; } if (isServer == 0 && hostPtr == NULL) { - FEerror("You must supply at least one of :host hostname or :server function",0); + Icall_error_handler(sLsimple_error, + make_simple_string("You must supply at least one of :host hostname or :server function"), + 0); } Iis_fixnum(port); inPort = (myport == Cnil ? 0 : fix(Iis_fixnum(myport))); @@ -2436,8 +2524,6 @@ object faslfile, data; #ifdef UNIX #ifdef BSD - FILE *fp; - int i; #ifdef HAVE_AOUT struct exec header; #endif diff -uNr TEST.gcl/gcl/o/format.c agcl/agcl/o/format.c --- TEST.gcl/gcl/o/format.c Sun Oct 27 22:06:42 2002 +++ agcl/agcl/o/format.c Mon Nov 4 17:54:13 2002 @@ -691,7 +691,10 @@ check_type_integer(&x); if (radix < 0 || radix > 36) { vs_push(make_fixnum(radix)); - FEerror("~D is illegal as a radix.", 1, vs_head); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~D is illegal as a radix."), + 1, + vs_head); } fmt_integer(x, colon, atsign, radix, mincol, padchar, commachar); } @@ -2098,7 +2101,10 @@ else if (type_of(strm) == t_string) { x = strm; if (!x->st.st_hasfillp) - FEerror("The string ~S doesn't have a fill-pointer.", 1, x); + Icall_error_handler(sLsimple_error, + make_simple_string("The string ~S doesn't have a fill-pointer."), + 1, + x); strm = make_string_output_stream(0); strm->sm.sm_object0 = x; } else @@ -2156,8 +2162,12 @@ { vs_push(make_simple_string(s)); vs_push(make_fixnum(&ctl_string[ctl_index] - fmt_string->st.st_self)); - FEerror("Format error: address@hidden"~A\"~%", - 3, vs_top[-2], vs_top[-1], fmt_string); + Icall_error_handler(sLsimple_error, + make_simple_string("Format error: address@hidden"~A\"~%"), + 3, + vs_top[-2], + vs_top[-1], + fmt_string); } DEFVAR("*INDENT-FORMATTED-OUTPUT*",sSAindent_formatted_outputA,SI,Cnil,""); diff -uNr TEST.gcl/gcl/o/funlink.c agcl/agcl/o/funlink.c --- TEST.gcl/gcl/o/funlink.c Tue Sep 24 05:08:33 2002 +++ agcl/agcl/o/funlink.c Mon Nov 4 17:54:13 2002 @@ -153,7 +153,9 @@ if (link_ar==Cnil && flag==Cnil) RETURN1(Cnil); check_type_array(&link_ar); if (link_ar->v.v_elttype != aet_ch) - { FEerror("*LINK-ARRAY* must be a string",0);} + { Icall_error_handler(sLsimple_type_error, + make_simple_string("*LINK-ARRAY* must be a string"), + 0);} ar = link_ar->v.v_self; ar_end = (object *)&(link_ar->ust.ust_self[link_ar->v.v_fillp]); switch (n) @@ -180,7 +182,10 @@ else if (type_of(sym)==t_cclosure) fun = sym; - else {FEerror("Second arg: ~a must be symbol or closure",0,sym); + else {Icall_error_handler(sLsimple_type_error, + make_simple_string("Second arg: ~a must be symbol or closure"), + 1, + sym); } if(Rset) { @@ -208,7 +213,9 @@ } break; default: - FEerror("Usage: (use-fast-links {nil,t} &optional fun)",0); + Icall_error_handler(sLsimple_error, + make_simple_string("Usage: (si:use-fast-links {nil,t} &optional fun)"), + 0); } RETURN1(Cnil); } @@ -564,7 +571,9 @@ x[43],x[44],x[45],x[46],x[47],x[48],x[49], x[50],x[51],x[52],x[53],x[54],x[55],x[56], x[57],x[58],x[59],x[60],x[61],x[62],x[63]);break; - default: FEerror("Exceeded call-arguments-limit ",0); + default: Icall_error_handler(sLsimple_error, + make_simple_string("Exceeded call-arguments-limit.") + ,0); } return res; @@ -603,7 +612,10 @@ { nargs= SFUN_NARGS(argd); if ((argd & (~VFUN_NARG_BIT)) != fun->sfn.sfn_argd) WRONG_ARGS: - FEerror("Arg or result mismatch in call to ~s",1,sym); + Icall_error_handler(sLsimple_error, + make_simple_string("Arg or result mismatch in call to ~s"), + 1, + sym); } (void) vpush_extend(link,sLAlink_arrayA->s.s_dbind); @@ -816,7 +828,9 @@ object set_mv(int i, object val) { if (i >= (sizeof(MVloc)/sizeof(object))) - FEerror("Bad mv index",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Bad mv index"), + 0); return(MVloc[i]=val); } @@ -825,10 +839,14 @@ mv_ref(unsigned int i) { object x; if (i >= (sizeof(MVloc)/sizeof(object))) - FEerror("Bad mv index",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Bad mv index"), + 0); x = MVloc[i]; if (x == 0) - FEerror("Null value",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Null value"), + 0); return x; } diff -uNr TEST.gcl/gcl/o/gmp_big.c agcl/agcl/o/gmp_big.c --- TEST.gcl/gcl/o/gmp_big.c Sat Jul 20 09:10:55 2002 +++ agcl/agcl/o/gmp_big.c Mon Nov 4 17:54:13 2002 @@ -60,10 +60,15 @@ static object verify_big_or_zero(object big) { int size; - if(type_of(big)!=t_bignum) FEerror("Not a bignum",0); + if(type_of(big)!=t_bignum) + Icall_error_handler(sLsimple_type_error, + make_simple_string("Not a bignum"), + 0); size = MP_SIZE(big); if ( size && (MP_SELF(big))[ABS(size)-1]==0) - FEerror("badly formed",0); + Icall_error_handler(sLsimple_error, + make_simple_string("badly formed"), + 0); return big; } @@ -313,7 +318,10 @@ { if (type_of(x)==t_bignum) return make_bignum(MP(x)); - else FEerror("bignum expected",0); + else + Icall_error_handler(sLsimple_type_error, + make_simple_string("bignum expected"), + 0); return Cnil; } @@ -351,7 +359,9 @@ return abs(MP(x)->_mp_size)*sizeof(*y->_mp_d); break; default: - FEerror("fixnum or bignum expected",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("fixnum or bignum expected"), + 0); break; } @@ -372,7 +382,9 @@ mpz_set(y,MP(x)); break; default: - FEerror("fixnum or bignum expected",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("fixnum or bignum expected"), + 0); break; } diff -uNr TEST.gcl/gcl/o/hash.d agcl/agcl/o/hash.d --- TEST.gcl/gcl/o/hash.d Fri Aug 2 00:15:06 2002 +++ agcl/agcl/o/hash.d Mon Nov 4 17:54:13 2002 @@ -331,19 +331,26 @@ else if (test == sLequal || test == sLequal->s.s_gfdef) htt = htt_equal; else - FEerror("~S is an illegal hash-table test function.", - 1, test); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal hash-table test function."), + 1, + test); if (type_of(size) != t_fixnum || 0 < fix(size)) ; else - FEerror("~S is an illegal hash-table size.", 1, size); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal hash-table size."), + 1, + size); if ((type_of(rehash_size) == t_fixnum && 0 < fix(rehash_size)) || (type_of(rehash_size) == t_shortfloat && 1.0 < sf(rehash_size)) || (type_of(rehash_size) == t_longfloat && 1.0 < lf(rehash_size))) ; else - FEerror("~S is an illegal hash-table rehash-size.", - 1, rehash_size); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal hash-table rehash-size."), + 1, + rehash_size); if ((type_of(rehash_threshold) == t_fixnum && 0 < fix(rehash_threshold) && fix(rehash_threshold) < fix(size)) || (type_of(rehash_threshold) == t_shortfloat && @@ -352,8 +359,10 @@ 0.0 < lf(rehash_threshold) && lf(rehash_threshold) < 1.0)) ; else - FEerror("~S is an illegal hash-table rehash-threshold.", - 1, rehash_threshold); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal hash-table rehash-threshold."), + 1, + rehash_threshold); {BEGIN_NO_INTERRUPT; h = alloc_object(t_hashtable); h->ht.ht_test = (short)htt; @@ -494,7 +503,9 @@ object ind; { int i = fix(ind); check_type_hash_table(&table); - if ( i < 0) { FEerror("needs non negative index",0);} + if ( i < 0) { Icall_error_handler(sLsimple_type_error, + make_simple_string("needs non negative index"), + 0);} while ( i < table->ht.ht_size) { if (table->ht.ht_self[i].hte_key != OBJNULL) { RETURN(3,object,make_fixnum(i+1), @@ -512,7 +523,10 @@ case htt_eq: RETURN1(sLeq); case htt_eql: RETURN1(sLeql); } - FEerror("not able to get hash table test for ~a",1,table); + Icall_error_handler(sLsimple_error, + make_simple_string("not able to get hash table test for ~a"), + 1, + table); RETURN1(sLnil); } diff -uNr TEST.gcl/gcl/o/iteration.c agcl/agcl/o/iteration.c --- TEST.gcl/gcl/o/iteration.c Tue Sep 24 21:01:45 2002 +++ agcl/agcl/o/iteration.c Mon Nov 4 17:54:13 2002 @@ -113,8 +113,10 @@ x = MMcdr(x); vs_push(MMcar(x)); if (!endp(MMcdr(x))) - FEerror("Too many forms to the index ~S.", - 1, y); + Icall_error_handler(sLsimple_error, + make_simple_string("Too many forms to the index ~S."), + 1, + y); } } } @@ -299,7 +301,9 @@ x = MMcar(arg); if (endp(x)) - FEerror("No variable.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("No variable."), + 0); start = (struct bind_temp *)vs_top; vs_push(MMcar(x)); vs_push(Cnil); @@ -307,7 +311,9 @@ vs_push(Cnil); x = MMcdr(x); if (endp(x)) - FEerror("No listform.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("No listform."), + 0); listform = MMcar(x); x = MMcdr(x); if (endp(x)) @@ -315,7 +321,9 @@ else { result = MMcar(x); if (!endp(MMcdr(x))) - FEerror("Too many resultforms.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Too many resultforms."), + 0); } make_nil_block(); @@ -380,7 +388,9 @@ x = MMcar(arg); if (endp(x)) - FEerror("No variable.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("No variable."), + 0); start = (struct bind_temp *)vs_top; vs_push(MMcar(x)); vs_push(Cnil); @@ -388,7 +398,9 @@ vs_push(Cnil); x = MMcdr(x); if (endp(x)) - FEerror("No countform.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("No countform."), + 0); countform = MMcar(x); x = MMcdr(x); if (endp(x)) @@ -396,7 +408,9 @@ else { result = MMcar(x); if (!endp(MMcdr(x))) - FEerror("Too many resultforms.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Too many resultforms."), + 0); } make_nil_block(); diff -uNr TEST.gcl/gcl/o/let.c agcl/agcl/o/let.c --- TEST.gcl/gcl/o/let.c Tue Sep 24 21:01:45 2002 +++ agcl/agcl/o/let.c Mon Nov 4 17:54:13 2002 @@ -49,8 +49,10 @@ FEerror("No initial form to the variable ~S.", 1, vs_top[-2]) */ ; else if (!endp(y->c.c_cdr)) - FEerror("Too many initial forms to the variable ~S.", - 1, vs_top[-2]); + Icall_error_handler(sLsimple_error, + make_simple_string("Too many initial forms to the variable ~S."), + 1, + vs_top[-2]); vs_push(y->c.c_car); vs_push(Cnil); } @@ -67,7 +69,9 @@ bds_ptr old_bds_top; if (endp(form)) - FEerror("No argument to LET.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("No argument to LET."), + 0); old_lex = lex_env; lex_copy(); @@ -95,8 +99,9 @@ bds_ptr old_bds_top; if (endp(form)) - FEerror("No argument to LET*.", 0); - + Icall_error_handler(sLsimple_error, + make_simple_string("No argument to LET."), + 0); old_lex = lex_env; lex_copy(); old_bds_top = bds_top; @@ -125,10 +130,14 @@ struct bind_temp *start; if (endp(form)) - FEerror("No argument to MULTIPLE-VALUE-BIND.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("No argument to MULTIPLE-VALUE-BIND."), + 0); body = form->c.c_cdr; if (endp(body)) - FEerror("No values-form to MULTIPLE-VALUE-BIND.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("No values-form to MULTIPLE-VALUE-BIND."), + 0); values_form = body->c.c_car; body = body->c.c_cdr; @@ -177,7 +186,9 @@ struct bind_temp *start, *end, *bt; if (endp(form)) - FEerror("No argument to COMPILER-LET.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("No argument to COMPILER-LET."), + 0); body = form->c.c_cdr; @@ -220,9 +231,10 @@ def = MMcar(def_list); if (endp(def) || endp(MMcdr(def)) || type_of(MMcar(def)) != t_symbol) - FEerror("~S~%\ -is an illegal function definition in FLET.", - 1, def); + Icall_error_handler(sLsimple_error, + make_simple_string("~S~%is an illegal function definition in FLET."), + 1, + def); top[0] = MMcons(lex[2], def); top[0] = MMcons(lex[1], top[0]); top[0] = MMcons(lex[0], top[0]); @@ -255,9 +267,10 @@ def = MMcar(def_list); if (endp(def) || endp(MMcdr(def)) || type_of(MMcar(def)) != t_symbol) - FEerror("~S~%\ -is an illegal function definition in LABELS.", - 1, def); + Icall_error_handler(sLsimple_error, + make_simple_string("~S~%is an illegal function definition in LABELS."), + 1, + def); top[0] = MMcons(lex[2], def); top[0] = MMcons(Cnil, top[0]); top[1] = MMcons(top[0], top[1]); @@ -294,9 +307,10 @@ def = MMcar(def_list); if (endp(def) || endp(MMcdr(def)) || type_of(MMcar(def)) != t_symbol) - FEerror("~S~%\ -is an illegal macro definition in MACROFLET.", - 1, def); + Icall_error_handler(sLsimple_error, + make_simple_string("~S~%is an illegal macro definition in MACROFLET."), + 1, + def); top[0] = ifuncall3(sSdefmacroA, MMcar(def), MMcadr(def), diff -uNr TEST.gcl/gcl/o/list.d agcl/agcl/o/list.d --- TEST.gcl/gcl/o/list.d Tue Oct 1 06:37:33 2002 +++ agcl/agcl/o/list.d Mon Nov 4 17:54:13 2002 @@ -119,7 +119,9 @@ item_compared = item; if (test != Cnil) { if (test_not != Cnil) - FEerror("Both :TEST and :TEST-NOT are specified.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Both :TEST and :TEST-NOT are specified."), + 0); test_function = test; tf = test_compare; } else if (test_not != Cnil) { @@ -631,7 +633,10 @@ object list; { object x = list; if (index < 0) - FEerror("Negative index: ~D.", 1, make_fixnum(index)); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Negative index: ~D."), + 1, + make_fixnum(index)); while (1) {if (type_of(x)==t_cons) { if (index == 0) @@ -747,7 +752,10 @@ if (n < 0) { vs_push(make_fixnum(n)); - FEerror("Negative index: ~D.", 1, vs_head); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Negative index: ~D."), + 1, + vs_head); } while (n-- > 0) if (endp(x)) { @@ -790,7 +798,10 @@ n=vs_top-vs_base; if (n!=1 && n!=2) - FEerror("Expected one or two arguments, received ~D.",1,make_fixnum(n)); + Icall_error_handler(sLsimple_error, + make_simple_string("Expected one or two arguments, received ~D."), + 1, + make_fixnum(n)); if (endp(vs_base[0])) return; if (n==2) { @@ -878,7 +889,10 @@ @ check_type_non_negative_integer(&size); if (type_of(size) != t_fixnum) - FEerror("Cannot make a list of the size ~D.", 1, size); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Cannot make a list of the size ~D."), + 1, + size); i = fix(size); while (i-- > 0) x = make_cons(initial_element, x); @@ -1128,7 +1142,9 @@ for (v=alist ; !endp(v) ; v=v->c.c_cdr) {if (type_of(v->c.c_car) != t_cons && v->c.c_car != Cnil) - FEerror("Not alist",0);} + Icall_error_handler(sLsimple_type_error, + make_simple_string("Not alist"), + 0);} return ; } @@ -1242,16 +1258,21 @@ d = data; while (!endp(k)) { if (endp(d)) - FEerror( - "The keys ~S and the data ~S are not of the same length", - 2, keys, data); + Icall_error_handler(sLsimple_error, + make_simple_string("The keys ~S and the data ~S are not of the same length"), + 2, + keys, + data); vs_check_push(make_cons(k->c.c_car, d->c.c_car)); k = k->c.c_cdr; d = d->c.c_cdr; } if (!endp(d)) - FEerror("The keys ~S and the data ~S are not of the same length", - 2, keys, data); + Icall_error_handler(sLsimple_error, + make_simple_string("The keys ~S and the data ~S are not of the same length"), + 2, + keys, + data); vs_push(a_list); while (vs_top > vp) stack_cons(); diff -uNr TEST.gcl/gcl/o/macros.c agcl/agcl/o/macros.c --- TEST.gcl/gcl/o/macros.c Tue Sep 24 21:01:45 2002 +++ agcl/agcl/o/macros.c Mon Nov 4 17:54:13 2002 @@ -41,8 +41,10 @@ if (symbol_value(sSAinhibit_macro_specialA) != Cnil) vs_base[0]->s.s_sfdef = NOT_SPECIAL; } else if (symbol_value(sSAinhibit_macro_specialA) != Cnil) - FEerror("~S, a special form, cannot be redefined.", - 1, vs_base[0]); + Icall_error_handler(sLsimple_error, + make_simple_string("~S, a special form, cannot be redefined."), + 1, + vs_base[0]); } clear_compiler_properties(vs_base[0],MMcaddr(vs_base[1])); if (vs_base[0]->s.s_hpack == lisp_package && @@ -100,8 +102,10 @@ if (symbol_value(sSAinhibit_macro_specialA) != Cnil) name->s.s_sfdef = NOT_SPECIAL; } else if (symbol_value(sSAinhibit_macro_specialA) != Cnil) - FEerror("~S, a special form, cannot be redefined.", - 1, name); + Icall_error_handler(sLsimple_error, + make_simple_string("~S, a special form, cannot be redefined."), + 1, + name); } clear_compiler_properties(name,MMcaddr(top[0])); if (name->s.s_hpack == lisp_package && diff -uNr TEST.gcl/gcl/o/main.c agcl/agcl/o/main.c --- TEST.gcl/gcl/o/main.c Fri Oct 11 09:53:14 2002 +++ agcl/agcl/o/main.c Mon Nov 4 17:54:14 2002 @@ -366,7 +366,10 @@ { sgc_quit();} if (sgc_enabled==0) { install_segmentation_catcher() ;} - FEerror("Caught fatal error [memory may be damaged]",0); } + Icall_error_handler(sKsimple_storage_condition, + make_simple_string("Caught fatal error: memory may be damaged."), + 0);} + /*FEerror("Caught fatal error [memory may be damaged]",0);*/ printf("\nUnrecoverable error: %s.\n", s); fflush(stdout); #ifdef UNIX @@ -535,7 +538,10 @@ if (vs_limit > vs_org + stack_multiple * VSSIZE) error("value stack overflow"); vs_limit += STACK_OVER*VSGETA; - FEerror("Value stack overflow.", 0); + /*FEerror("Value stack overflow.", 0);*/ + Icall_error_handler(sKsimple_storage_condition, + make_simple_string("Value stack overflow."), + 0); return Cnil; } @@ -546,7 +552,9 @@ error("bind stack overflow"); } bds_limit += STACK_OVER *BDSGETA; - FEerror("Bind stack overflow.", 0); + Icall_error_handler(sKsimple_storage_condition, + make_simple_string("Bind stack overflow."), + 0); } void @@ -555,7 +563,9 @@ if (frs_limit > frs_org + stack_multiple * FRSSIZE) error("frame stack overflow"); frs_limit += STACK_OVER* FRSGETA; - FEerror("Frame stack overflow.", 0); + Icall_error_handler(sKsimple_storage_condition, + make_simple_string("Frame stack overflow."), + 0); } void @@ -564,7 +574,9 @@ if (ihs_limit > ihs_org + stack_multiple * IHSSIZE) error("invocation history stack overflow"); ihs_limit += STACK_OVER*IHSGETA; - FEerror("Invocation history stack overflow.", 0); + Icall_error_handler(sKsimple_storage_condition, + make_simple_string("Invocation history stack overflow."), + 0); } void @@ -591,7 +603,9 @@ #endif - FEerror("Control stack overflow.", 0); + Icall_error_handler(sKsimple_storage_condition, + make_simple_string("Control stack overflow."), + 0); } void @@ -652,7 +666,10 @@ if (type_of(vs_base[0]) != t_fixnum || (i = fix(vs_base[0])) < 0 || i >= ARGC) - FEerror("Illegal argument index: ~S.", 1, vs_base[0]); + Icall_error_handler(sLcell_error, + make_simple_string("Illegal argument index: ~S."), + 1, + vs_base[0]); vs_base[0] = make_simple_string(ARGV[i]); } @@ -669,7 +686,10 @@ check_arg(1); check_type_string(&vs_base[0]); if (vs_base[0]->st.st_fillp >= 256) - FEerror("Too long name: ~S.", 1, vs_base[0]); + Icall_error_handler(sLcell_error, + make_simple_string("Too long name: ~S."), + 1, + vs_base[0]); for (i = 0; i < vs_base[0]->st.st_fillp; i++) name[i] = vs_base[0]->st.st_self[i]; name[i] = '\0'; @@ -699,7 +719,9 @@ siLcheck_vs(void) { check_arg(0); if (vs_base != vs_marker) - FEerror("Value stack is flawed.", 0); + Icall_error_handler(sKsimple_storage_condition, + make_simple_string("Value stack is flawed."), + 0); vs_base[0] = Cnil; } diff -uNr TEST.gcl/gcl/o/makefun.c agcl/agcl/o/makefun.c --- TEST.gcl/gcl/o/makefun.c Sat Jul 20 16:38:21 2002 +++ agcl/agcl/o/makefun.c Mon Nov 4 17:54:14 2002 @@ -52,7 +52,9 @@ might move while in the closure. */ object *p; if (type_of(x) != t_closure) - { FEerror("Not a closure",0);} + { Icall_error_handler(sLsimple_type_error, + make_simple_string("Not a closure"), + 0);} if (x->cl.cl_envdim < n) {BEGIN_NO_INTERRUPT; x->cl.cl_env = (object *)alloc_contblock(n); x->cl.cl_envdim = n; diff -uNr TEST.gcl/gcl/o/nfunlink.c agcl/agcl/o/nfunlink.c --- TEST.gcl/gcl/o/nfunlink.c Sat Jul 20 09:10:55 2002 +++ agcl/agcl/o/nfunlink.c Mon Nov 4 17:54:14 2002 @@ -156,7 +156,9 @@ res = COERCE_F_TYPE(res,F_object,restype); #ifdef DEBUG if (oldctl != frs_top || oldbd != bds_top) - FEerror("compiler error ? ",0 ); + Icall_error_handler(sLsimple_error, + make_simple_string("compiler error ? "), + 0 ); #endif return res; }} @@ -218,7 +220,9 @@ else if (atyp == F_double_ptr) { ASSURE_TYPE(next,t_longfloat); next = COERCE_F_TYPE(next,F_object,F_double_ptr);} - else {FEerror("cant get here!",0);} + else {Icall_error_handler(sLsimple_error, + make_simple_string("o/nfunlink.c -- can't get here!"), + 0);} vs_push(next);} } @@ -268,7 +272,9 @@ min = F_MIN_ARGS(fargd); max = F_MAX_ARGS(fargd); if (nargs < min || nargs > max) - { FEerror("Wrong number of args",0); + { Icall_error_handler(sLsimple_error, + make_simple_string("Wrong number of args") + ,0); } for (i=0; i < nargs ; i++, atypes >>= F_TYPE_WIDTH) { object next = base[i]; @@ -284,7 +290,9 @@ else if (atyp == F_double_ptr) { ASSURE_TYPE(next,t_longfloat); x[i] = COERCE_F_TYPE(next,F_object,F_double_ptr);} - else {FEerror("cant get here!",0);}} + else {Icall_error_handler(sLsimple_error, + make_simple_string("nfunlink.c -- can't get here, either!"), + 0);}} VFUN_NARGS = nargs; res = c_apply_n(f,nargs,x); res = COERCE_F_TYPE(res,F_RESULT_TYPE(fargd),F_object); diff -uNr TEST.gcl/gcl/o/nsocket.c agcl/agcl/o/nsocket.c --- TEST.gcl/gcl/o/nsocket.c Wed Jul 24 05:35:44 2002 +++ agcl/agcl/o/nsocket.c Mon Nov 4 17:54:14 2002 @@ -543,7 +543,9 @@ if (bufp->ust.ust_fillp < bufp->ust.ust_dim) { bufp->ust.ust_self[(bufp->ust.ust_fillp)++]=c; } else { - FEerror("Tried to unget too many chars",0); + Icall_error_handler(sLsimple_error, + make_simple_string("Tried to unget too many chars."), + 0); } } @@ -650,7 +652,9 @@ else { return EOF; - FEerror("select said there was stuff there but there was not",0); + Icall_error_handler(sLsimple_error, + make_simple_string("'select' said there was stuff there but there was not"), + 0); } } /* probably a signal interrupted us.. */ diff -uNr TEST.gcl/gcl/o/num_arith.c agcl/agcl/o/num_arith.c --- TEST.gcl/gcl/o/num_arith.c Sat Jul 20 09:10:55 2002 +++ agcl/agcl/o/num_arith.c Mon Nov 4 17:54:14 2002 @@ -670,16 +670,22 @@ case t_fixnum: case t_bignum: if(number_zerop(y) == TRUE) - zero_divisor(); + Icall_error_handler(sLdivision_by_zero, + make_simple_string("DIVISION with operands ~A is an error."), + 1, + make_cons(x, make_cons(y, Cnil))); if (number_minusp(y) == TRUE) { - x = number_negate(x); - y = number_negate(y); + x = number_negate(x); + y = number_negate(y); } z = make_ratio(x, y); return(z); case t_ratio: if(number_zerop(y->rat.rat_num)) - zero_divisor(); + Icall_error_handler(sLdivision_by_zero, + make_simple_string("DIVISION with operands ~A is an error."), + 1, + make_cons(x, make_cons(y, Cnil))); z = make_ratio(number_times(x, y->rat.rat_den), y->rat.rat_num); return(z); case t_shortfloat: @@ -701,7 +707,10 @@ case t_fixnum: case t_bignum: if (number_zerop(y)) - zero_divisor(); + Icall_error_handler(sLdivision_by_zero, + make_simple_string("DIVISION with operands ~A is an error."), + 1, + make_cons(x, make_cons(y, Cnil))); z = make_ratio(x->rat.rat_num, number_times(x->rat.rat_den, y)); return(z); case t_ratio: @@ -746,7 +755,10 @@ SHORTFLOAT: z = alloc_object(t_shortfloat); if (dy == 0.0) - zero_divisor(); + Icall_error_handler(sLdivision_by_zero, + make_simple_string("DIVISION with operands ~A is an error."), + 1, + make_cons(x, make_cons(y, Cnil))); sf(z) = (shortfloat)(dx / dy); return(z); @@ -771,7 +783,10 @@ LONGFLOAT: z = alloc_object(t_longfloat); if (dy == 0.0) - zero_divisor(); + Icall_error_handler(sLdivision_by_zero, + make_simple_string("DIVISION with operands ~A is an error."), + 1, + make_cons(x, make_cons(y, Cnil))); lf(z) = dx / dy; return(z); @@ -785,7 +800,10 @@ z1 = number_times(y->cmp.cmp_real, y->cmp.cmp_real); z2 = number_times(y->cmp.cmp_imag, y->cmp.cmp_imag); if (number_zerop(z3 = number_plus(z1, z2))) - zero_divisor(); + Icall_error_handler(sLdivision_by_zero, + make_simple_string("DIVISION with operands ~A is an error."), + 1, + make_cons(x, make_cons(y, Cnil))); z1 = number_times(x->cmp.cmp_real, y->cmp.cmp_real); z2 = number_times(x->cmp.cmp_imag, y->cmp.cmp_imag); z1 = number_plus(z1, z2); @@ -1016,12 +1034,13 @@ vs_top = vs_base+1; } +/* void zero_divisor(void) { FEerror("Zero divisor.", 0); } - +*/ void init_num_arith(void) { diff -uNr TEST.gcl/gcl/o/num_co.c agcl/agcl/o/num_co.c --- TEST.gcl/gcl/o/num_co.c Fri Nov 1 03:30:43 2002 +++ agcl/agcl/o/num_co.c Mon Nov 4 17:54:14 2002 @@ -964,7 +964,10 @@ if (type_of(vs_base[1]) == t_fixnum) k = fix(vs_base[1]); else - FEerror("~S is an illegal exponent.", 1, vs_base[1]); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal exponent."), + 1, + vs_base[1]); if (type_of(x) == t_shortfloat) d = sf(x); else @@ -986,7 +989,10 @@ #ifdef S3000 if (e < -64 || e >= 64) #endif - FEerror("~S is an illegal exponent.", 1, vs_base[1]); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal exponent."), + 1, + vs_base[1]); d = set_exponent(d, e); vs_popp; if (type_of(x) == t_shortfloat) @@ -1190,6 +1196,76 @@ } } +static float sf1,sf2; +static int sf_eql(void) +{return(sf1==sf2);} + + + +int lf_eqlp(double *p, double *q); +#define LF_EQL(a,b) (lf1=a,lf2=b,lf_eqlp(&lf1,&lf2)) +#define SF_EQL(a,b) (sf1=a,sf2=b,sf_eql()) + +void _assure_in_memory (void *p); + +#define FMEM(f) _assure_in_memory(&f) + +#ifdef IEEEFLOAT +/* from ieee754.h */ + +typedef union { + float f; + + /* This is the IEEE 754 single-precision format. */ + struct float_bits + { +#ifndef LITTLE_END + unsigned int negative:1; + unsigned int exponent:8; + unsigned int mantissa:23; +#else /* Big endian. */ + unsigned int mantissa:23; + unsigned int exponent:8; + unsigned int negative:1; +#endif /* Little endian. */ + } ieee; +} IEEE_float; + +typedef union { + + double d; + + /* This is the IEEE 754 double-precision format. */ + struct double_bits + { +#ifndef LITTLE_END + unsigned int negative:1; + unsigned int exponent:11; + /* Together these comprise the mantissa. */ + unsigned int mantissa0:20; + unsigned int mantissa1:32; +#else /* Big endian. */ + /* # if __FLOAT_WORD_ORDER == BIG_ENDIAN */ + /* unsigned int mantissa0:20; */ + /* unsigned int exponent:11; */ + /* unsigned int negative:1; */ + /* unsigned int mantissa1:32; */ + /* # else */ + /* Together these comprise the mantissa. */ + unsigned int mantissa1:32; + unsigned int mantissa0:20; + unsigned int exponent:11; + unsigned int negative:1; + /* # endif */ +#endif /* Little endian. */ + } ieee; +} IEEE_double; + + +#endif + + + void init_num_co(void) { @@ -1197,6 +1273,8 @@ double smallest_double, smallest_norm_double, biggest_double; float float_epsilon, float_negative_epsilon; double double_epsilon, double_negative_epsilon; + double lf1,lf2; + #ifdef VAX @@ -1309,42 +1387,81 @@ biggest_float = FLT_MAX; #endif - { - - volatile double rd,dd,td,td1; - volatile float rf,df,tf,tf1; - int i,j; -#define MAX 500 - - for (rf=1.0f,df=0.5f,i=j=0;icmp.cmp_real:y)) - FEerror("Cannot raise zero to the power ~S.", 1, y); + Icall_error_handler(sLdivision_by_zero, + make_simple_string("EXPT operation with operands ~S is an error."), + 1, + make_cons(x, make_cons(y, Cnil))); return(number_times(x, y)); } if (ty == t_fixnum || ty == t_bignum) { @@ -172,7 +175,10 @@ goto COMPLEX; } if (number_zerop(x)) - FEerror("Zero is the logarithmic singularity.", 0); + Icall_error_handler(sLdivision_by_zero, + make_simple_string("Zero is the logarithmic singularity: ~A"), + 1, + x); if (number_minusp(x)) { r = x; i = small_fixnum(0); @@ -219,7 +225,10 @@ vs_mark; if (number_zerop(y)) - FEerror("Zero is the logarithmic singularity.", 0); + Icall_error_handler(sLdivision_by_zero, + make_simple_string("LOG operation with operands ~A is an error."), + 1, + make_cons(x, make_cons(y, Cnil))); if (number_zerop(x)) return(number_times(x, y)); x = number_nlog(x); @@ -286,7 +295,10 @@ if (dy > 0.0) dz = PI / 2.0; else if (dy == 0.0) - FEerror("Logarithmic singularity.", 0); + Icall_error_handler(sLdivision_by_zero, + make_simple_string("Logarithmic singularity: operands ~A."), + 1, + make_cons(x, make_cons(y, Cnil))); else dz = -PI / 2.0; else @@ -481,7 +493,10 @@ c = number_cos(x); vs_push(c); if (number_zerop(c) == TRUE) - FEerror("Cannot compute the tangent of ~S.", 1, x); + Icall_error_handler(sLdivision_by_zero, + make_simple_string("Cannot compute the tangent of ~S."), + 1, + x); r = number_tan1(x); vs_reset; return(r); diff -uNr TEST.gcl/gcl/o/number.c agcl/agcl/o/number.c --- TEST.gcl/gcl/o/number.c Mon Sep 30 07:12:03 2002 +++ agcl/agcl/o/number.c Mon Nov 4 17:54:14 2002 @@ -42,7 +42,10 @@ fixnnint(object x) { if (type_of(x) != t_fixnum || fix(x) < 0) - FEerror("~S is not a non-negative fixnum.", 1, x); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is not a non-negative fixnum."), + 1, + x); return(fix(x)); } @@ -56,7 +59,9 @@ SI,2,2,NONE,OI,IO,OO,OO,"") (min,max) int min,max; { int j; - if (min <= max); else {FEerror("Need Min < Max",0);} + if (min <= max); else {Icall_error_handler(sLsimple_type_error, + make_simple_string("Need Min < Max"), + 0);} bigger_fixnum_table= (void *) malloc(sizeof(struct fixnum_struct)* (max - min)); @@ -101,7 +106,10 @@ vs_mark; if (number_zerop(den)) - FEerror("Zero denominator.", 0); + Icall_error_handler(sLdivision_by_zero, + make_simple_string("DIVISION with operands ~S is an error."), + 1, + make_cons(num, make_cons(den, Cnil))); if (number_zerop(num)) return(small_fixnum(0)); if (type_of(den) == t_fixnum && fix(den) == 1) diff -uNr TEST.gcl/gcl/o/package.d agcl/agcl/o/package.d --- TEST.gcl/gcl/o/package.d Fri Oct 25 04:41:49 2002 +++ agcl/agcl/o/package.d Wed Nov 6 21:36:00 2002 @@ -330,8 +330,10 @@ x = symbol_value(sLApackageA); if (type_of(x) != t_package) { sLApackageA->s.s_dbind = user_package; - FEerror("The value of *PACKAGE*, ~S, was not a package.", - 1, x); + Icall_error_handler(sLpackage_error, + make_simple_string("The value of *PACKAGE*, ~S, was not a package."), + 1, + x); } return(x); } @@ -1103,8 +1105,10 @@ check_type_package(&vs_base[0]); if (type_of(vs_base[1]) != t_fixnum || (j = fix(vs_base[1])) < 0 || j >= vs_base[0]->p.p_internal_size) - FEerror("~S is an illegal index to a package hashtable.", - 1, vs_base[1]); + Icall_error_handler(sLpackage_error, + make_simple_string("~S is an illegal index to a package hashtable."), + 1, + vs_base[1]); vs_base[0] = P_INTERNAL(vs_base[0],j); vs_popp; } @@ -1118,8 +1122,10 @@ check_type_package(&vs_base[0]); if (type_of(vs_base[1]) != t_fixnum || (j = fix(vs_base[1])) < 0 || j >= vs_base[0]->p.p_external_size) - FEerror("~S is an illegal index to a package hashtable.", - 1, vs_base[1]); + Icall_error_handler(sLpackage_error, + make_simple_string("~S is an illegal index to a package hashtable."), + 1, + vs_base[1]); vs_base[0] = P_EXTERNAL(vs_base[0],j); vs_popp; } @@ -1128,7 +1134,11 @@ no_package(n) object n; { - FEwrong_type_argument(TSor_symbol_string_package,n); + Icall_error_handler(sKsimple_package_error, + make_simple_string("There is no package with the name ~S."), + 1, + n); + } void @@ -1170,9 +1180,47 @@ Cnil, make_cons(lisp_package, Cnil),509,97); #ifdef ANSI_COMMON_LISP + + slot_accessor_name_package + = make_package(make_simple_string("SLOT-ACCESSOR-NAME"), + make_cons(make_simple_string("S-A-N"), + Cnil), + Cnil, + 8191,1021); + common_lisp_package = make_package(make_simple_string("COMMON-LISP"), Cnil, Cnil,47,509); + + walker_package + = make_package(make_simple_string("WALKER"), + Cnil, + make_cons(make_simple_string("LISP"), + Cnil), + 2039,97); + iterate_package + = make_package(make_simple_string("ITERATE"), + Cnil, + make_cons(make_simple_string("WALKER"), + (make_cons(make_simple_string("LISP"), + Cnil))), + 157,97); + pcl_package + = make_package(make_simple_string("PCL"), + Cnil, + make_cons(make_simple_string("WALKER"), + (make_cons(make_simple_string("ITERATE"), + (make_cons(make_simple_string("LISP"), + Cnil))))), + 97,157); + conditions_package + = make_package(make_simple_string("CONDITIONS"), + make_cons(make_simple_string("CLCS"), + Cnil), + make_cons(make_simple_string("LISP"), + (make_cons(make_simple_string("PCL"), + Cnil))), + 1021,97); #endif keyword_package = make_package(make_simple_string("KEYWORD"), diff -uNr TEST.gcl/gcl/o/pathname.d agcl/agcl/o/pathname.d --- TEST.gcl/gcl/o/pathname.d Sun Oct 27 22:06:42 2002 +++ agcl/agcl/o/pathname.d Mon Nov 4 17:54:14 2002 @@ -274,7 +274,10 @@ default: CANNOT_COERCE: - FEerror("~S cannot be coerced to a pathname.", 1, x); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S cannot be coerced to a pathname."), + 1, + x); return(Cnil); } } @@ -420,7 +423,10 @@ goto M; } if (type_of(y) != t_string) - FEerror("~S is an illegal pathname name.", 1, y); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal pathname name."), + 1, + y); for (j = 0; j < y->st.st_fillp; j++) token->st.st_self[i++] = y->st.st_self[j]; M: @@ -438,7 +444,10 @@ goto N; } if (type_of(y) != t_string) - FEerror("~S is an illegal pathname name.", 1, y); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal pathname name."), + 1, + y); token->st.st_self[i++] = '.'; for (j = 0; j < y->st.st_fillp; j++) token->st.st_self[i++] = y->st.st_self[j]; @@ -505,7 +514,10 @@ default: CANNOT_COERCE: - FEerror("~S cannot be coerced to a namestring.", 1, x); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S cannot be coerced to a namestring."), + 1, + x); return(Cnil); } } @@ -547,9 +559,13 @@ if (!isspace((int)x->st.st_self[s + ee])) break; if (y == OBJNULL || ee != e - s) - FEerror("Cannot parse the namestring ~S~%\ -from ~S to ~S.", - 3, x, start, end); + Icall_error_handler(sLparse_error, + make_simple_string("Cannot parse the namestring ~S~%\ + from ~S to ~S."), + 3, + x, + start, + end); } else if (y == OBJNULL) @(return Cnil `make_fixnum(s + ee)`) @@ -583,12 +599,18 @@ default: CANNOT_PARSE: - FEerror("Cannot parse the namestring ~S.", 1, x); + Icall_error_handler(sLparse_error, + make_simple_string("Cannot parse the namestring ~S."), + 1, + x); } if (host != Cnil && y->pn.pn_host != Cnil && host != y->pn.pn_host) - FEerror("The hosts ~S and ~S do not match.", - 2, host, y->pn.pn_host); + Icall_error_handler(sLsimple_error, + make_simple_string("The hosts ~S and ~S do not match."), + 2, + host, + y->pn.pn_host); @(return y start) @) diff -uNr TEST.gcl/gcl/o/print.d agcl/agcl/o/print.d --- TEST.gcl/gcl/o/print.d Thu Oct 3 07:32:38 2002 +++ agcl/agcl/o/print.d Mon Nov 4 17:54:14 2002 @@ -82,7 +82,9 @@ if (qc >= Q_SIZE) flush_queue(FALSE); if (qc >= Q_SIZE) - FEerror("Can't pretty-print.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Can't pretty-print."), + 0); queue[qt] = c; qt = mod(qt+1); qc++; @@ -147,7 +149,9 @@ qh = mod(qh+1); --qc; if (++isp >= IS_SIZE-1) - FEerror("Can't pretty-print.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Can't pretty-print."), + 0); indent_stack[isp++] = file_column(PRINTstream); indent_stack[isp] = indent_stack[isp-1]; goto BEGIN; @@ -323,8 +327,9 @@ return; } else - FEerror("Can't print a non-number.", - 0);} + Icall_error_handler(sLsimple_type_error, + make_simple_string("Can't print a non-number."), + 0);} else sprintf(buff, "%*.*e",FPRC+8,FPRC, d); if (buff[FPRC+3] != 'e') { @@ -841,7 +846,9 @@ else if (intern_flag == EXTERNAL) write_ch(':'); else - FEerror("Pathological symbol --- cannot print.", 0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Pathological symbol --- cannot print."), + 0); } k = 0; if (potential_number_p(x, PRINTbase)) @@ -1475,7 +1482,10 @@ if (type_of(y) != t_fixnum || fix(y) < 2 || fix(y) > 36) { sLAprint_baseA->s.s_dbind = make_fixnum(10); vs_push(y); - FEerror("~S is an illegal PRINT-BASE.", 1, y); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal PRINT-BASE."), + 1, + y); } else PRINTbase = fix(y); PRINTradix = symbol_value(sLAprint_radixA) != Cnil; @@ -1484,7 +1494,10 @@ PRINTcase != sKcapitalize) { sLAprint_caseA->s.s_dbind = sKdowncase; vs_push(PRINTcase); - FEerror("~S is an illegal PRINT-CASE.", 1, PRINTcase); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal PRINT-CASE."), + 1, + PRINTcase); } PRINTgensym = symbol_value(sLAprint_gensymA) != Cnil; y = symbol_value(sLAprint_levelA); @@ -1493,7 +1506,10 @@ else if (type_of(y) != t_fixnum || fix(y) < 0) { sLAprint_levelA->s.s_dbind = Cnil; vs_push(y); - FEerror("~S is an illegal PRINT-LEVEL.", 1, y); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal PRINT-LEVEL."), + 1, + y); } else PRINTlevel = fix(y); y = symbol_value(sLAprint_lengthA); @@ -1502,7 +1518,10 @@ else if (type_of(y) != t_fixnum || fix(y) < 0) { sLAprint_lengthA->s.s_dbind = Cnil; vs_push(y); - FEerror("~S is an illegal PRINT-LENGTH.", 1, y); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal PRINT-LENGTH."), + 1, + y); } else PRINTlength = fix(y); PRINTarray = symbol_value(sLAprint_arrayA) != Cnil; @@ -1604,7 +1623,10 @@ else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); if (type_of(strm) != t_stream) - FEerror("~S is not a stream.", 1, strm); + Icall_error_handler(sLstream_error, + make_simple_string("~S is not a stream."), + 1, + strm); PRINTvs_top = vs_top; PRINTstream = strm; PRINTreadably = readably != Cnil; @@ -1612,25 +1634,37 @@ PRINTpretty = pretty != Cnil; PRINTcircle = circle != Cnil; if (type_of(base)!=t_fixnum || fix((base))<2 || fix((base))>36) - FEerror("~S is an illegal PRINT-BASE.", 1, base); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal PRINT-BASE."), + 1, + base); else PRINTbase = fix((base)); PRINTradix = radix != Cnil; PRINTcase = cas; if (PRINTcase != sKupcase && PRINTcase != sKdowncase && PRINTcase != sKcapitalize) - FEerror("~S is an illegal PRINT-CASE.", 1, cas); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal PRINT-CASE."), + 1, + cas); PRINTgensym = PRINTreadably || gensym != Cnil; if (PRINTreadably || level == Cnil) PRINTlevel = -1; else if (type_of(level) != t_fixnum || fix((level)) < 0) - FEerror("~S is an illegal PRINT-LEVEL.", 1, level); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal PRINT-LEVEL."), + 1, + level); else PRINTlevel = fix((level)); if (PRINTreadably || length == Cnil) PRINTlength = -1; else if (type_of(length) != t_fixnum || fix((length)) < 0) - FEerror("~S is an illegal PRINT-LENGTH.", 1, length); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal PRINT-LENGTH."), + 1, + length); else PRINTlength = fix((length)); PRINTarray = PRINTreadably || array != Cnil; @@ -1799,7 +1833,10 @@ @(defun write_byte (integer binary_output_stream) @ if (type_of(integer) != t_fixnum) - FEerror("~S is not a byte.", 1, integer); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is not a byte."), + 1, + integer); check_type_stream(&binary_output_stream); writec_stream(fix(integer), binary_output_stream); @(return integer) @@ -1873,7 +1910,10 @@ else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); if (type_of(strm) != t_stream) - FEerror("~S is not a stream.", 1, strm); + Icall_error_handler(sLstream_error, + make_simple_string("~S is not a stream."), + 1, + strm); if (obj == OBJNULL) goto SIMPLE_CASE; switch (type_of(obj)) { @@ -1912,7 +1952,10 @@ else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); if (type_of(strm) != t_stream) - FEerror("~S is not a stream.", 1, strm); + Icall_error_handler(sLstream_error, + make_simple_string("~S is not a stream."), + 1, + strm); if (obj == OBJNULL) goto SIMPLE_CASE; switch (type_of(obj)) { @@ -1958,7 +2001,10 @@ else if (strm == Ct) strm = symbol_value(sLAterminal_ioA); if (type_of(strm) != t_stream) - FEerror("~S is not a stream.", 1, strm); + Icall_error_handler(sLstream_error, + make_simple_string("~S is not a stream."), + 1, + strm); WRITEC_NEWLINE(strm); flush_stream(strm); return(Cnil); diff -uNr TEST.gcl/gcl/o/prog.c agcl/agcl/o/prog.c --- TEST.gcl/gcl/o/prog.c Tue Sep 24 21:01:45 2002 +++ agcl/agcl/o/prog.c Mon Nov 4 17:54:14 2002 @@ -85,7 +85,9 @@ tinf += 2) ; if (tinf >= new_top) - FEerror("Someone tried to RETURN-FROM a TAGBODY.",0); + Icall_error_handler(sKsimple_control_error, + make_simple_string("Someone tried to RETURN-FROM a TAGBODY."), + 0); body = tinf[1]; } while (body != Cnil) { @@ -181,10 +183,16 @@ FEtoo_many_argumentsF(args); lex_tag = lex_tag_sch(MMcar(args)); if (MMnull(lex_tag)) - FEerror("~S is an undefined tag.", 1, MMcar(args)); + Icall_error_handler(sKsimple_control_error, + make_simple_string("~S is an undefined tag."), + 1, + MMcar(args)); fr = frs_sch(MMcaddr(lex_tag)); if (fr == NULL) - FEerror("The tag ~S is missing.", 1, MMcar(args)); + Icall_error_handler(sKsimple_control_error, + make_simple_string("The tag ~S is missing."), + 1, + MMcar(args)); vs_push(MMcons(MMcaddr(lex_tag), MMcar(lex_tag))); vs_base = vs_top; unwind(fr,vs_top[-1]); @@ -220,7 +228,10 @@ if (type_of(var)!=t_symbol) not_a_symbol(var); if ((enum stype)var->s.s_stype == stp_constant) - FEerror("Cannot bind the constant ~S.", 1, var); + Icall_error_handler(sLcell_error, + make_simple_string("Cannot bind the constant ~S."), + 1, + var); if (endp(values)) { bds_bind(var, OBJNULL); diff -uNr TEST.gcl/gcl/o/read.d agcl/agcl/o/read.d --- TEST.gcl/gcl/o/read.d Tue Sep 24 21:01:45 2002 +++ agcl/agcl/o/read.d Mon Nov 4 17:54:14 2002 @@ -77,14 +77,19 @@ else { vs_push(x); sLAread_default_float_formatA->s.s_dbind = sLsingle_float; - FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*, ~S, was illegal.", - 1, x); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("The value of *READ-DEFAULT-FLOAT-FORMAT*, ~S, was illegal."), + 1, + x); } x = symbol_value(sLAread_baseA); if (type_of(x) != t_fixnum || fix(x) < 2 || fix(x) > 36) { vs_push(x); sLAread_baseA->s.s_dbind = make_fixnum(10); - FEerror("The value of *READ-BASE*, ~S, was illegal.", 1, x); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("The value of *READ-BASE*, ~S, was illegal."), + 1, + x); } READbase = fix(x); READsuppress = symbol_value(sLAread_suppressA) != Cnil; @@ -177,14 +182,19 @@ else { vs_push(x); sLAread_default_float_formatA->s.s_dbind = sLsingle_float; - FEerror("The value of *READ-DEFAULT-FLOAT-FORMAT*, ~S, was illegal.", - 1, x); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("The value of *READ-DEFAULT-FLOAT-FORMAT*, ~S, was illegal."), + 1, + x); } x = symbol_value(sLAread_baseA); if (type_of(x) != t_fixnum || fix(x) < 2 || fix(x) > 36) { vs_push(x); sLAread_baseA->s.s_dbind = make_fixnum(10); - FEerror("The value of *READ-BASE*, ~S, was illegal.", 1, x); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("The value of *READ-BASE*, ~S, was illegal."), + 1, + x); } READbase = fix(x); READsuppress = symbol_value(sLAread_suppressA) != Cnil; @@ -450,8 +460,11 @@ } if (i > 1) { vs_push(make_fixnum(i)); - FEerror("The readmacro ~S returned ~D values.", - 2, fun_box[0], vs_top[-1]); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("The readmacro ~S returned ~D values."), + 2, + fun_box[0], + vs_top[-1]); } result = vs_base[0]; vs_base = old_vs_base; @@ -524,7 +537,9 @@ for (i = 0; i < length; i++) if (token->st.st_self[i] != '.') goto N; - FEerror("Dots appeared illegally.", 0); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("Dots appeared illegally."), + 0); } N: @@ -546,8 +561,10 @@ p = find_package(token); if (p == Cnil) { vs_push(copy_simple_string(token)); - FEerror("There is no package with the name ~A.", - 1, vs_head); + Icall_error_handler(sKsimple_package_error, + make_simple_string("There is no package with the name ~A."), + 1, + vs_head); } } for (i = colon + 1; i < length; i++) @@ -558,8 +575,11 @@ x = find_symbol(token, p); if (intern_flag != EXTERNAL) { vs_push(copy_simple_string(token)); - FEerror("Cannot find the external symbol ~A in ~S.", - 2, vs_head, p); + Icall_error_handler(sKsimple_package_error, + make_simple_string("Cannot find the external symbol ~A in ~S."), + 2, + vs_head, + p); /* no need to push a package */ } vs_reset; @@ -570,8 +590,10 @@ p = find_package(token); if (p == Cnil) { vs_push(copy_simple_string(token)); - FEerror("There is no package with the name ~A.", - 1, vs_head); + Icall_error_handler(sKsimple_package_error, + make_simple_string("There is no package with the name ~A."), + 1, + vs_head); } for (i = colon + 2; i < length; i++) token_buffer[i - (colon + 2)] @@ -611,16 +633,22 @@ goto ENDUP; if (dot_flag) { if (p == &vs_head) - FEerror("A dot appeared after a left parenthesis.", 0); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("A dot appeared after a left parenthesis."), + 0); in_list_flag = TRUE; *p = read_object(in); if (dot_flag) - FEerror("Two dots appeared consecutively.", 0); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("Two dots appeared consecutively."), + 0); c = read_char(in); while (cat(c) == cat_whitespace) c = read_char(in); if (char_code(c) != ')') - FEerror("A dot appeared before a right parenthesis.", 0); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("A dot appeared before a right parenthesis."), + 0); goto ENDUP; } vs_push(x); @@ -847,7 +875,9 @@ #ifdef IEEEFLOAT /* if ((*((int *)&fraction +HIND) & 0x7ff00000) == 0x7ff00000)*/ if (!ISFINITE(fraction)) - FEerror("Floating-point overflow.", 0); + Icall_error_handler(sKsimple_fp_overflow, + make_simple_string("Floating-point overflow."), + 0); #endif switch (exponent_marker) { @@ -1048,7 +1078,10 @@ c = vs_base[1]; if (READtable->rt.rt_self[char_code(c)].rte_dtab == NULL) - FEerror("~C is not a dispatching macro character", 1, c); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("~C is not a dispatching macro character"), + 1, + c); c = read_char(in); d = digitp(char_code(c), 10); @@ -1133,21 +1166,29 @@ vs_popp; c = read_char(vs_base[0]); if (char_code(c) != '(') - FEerror("A left parenthesis is expected.", 0); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("A left parenthesis is expected."), + 0); delimiting_char = code_char(')'); x = read_object(vs_base[0]); if (x == OBJNULL) - FEerror("No real part.", 0); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("No real part."), + 0); vs_push(x); delimiting_char = code_char(')'); x = read_object(vs_base[0]); if (x == OBJNULL) - FEerror("No imaginary part.", 0); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("No imaginary part."), + 0); vs_push(x); delimiting_char = code_char(')'); x = read_object(vs_base[0]); if (x != OBJNULL) - FEerror("A right parenthesis is expected.", 0); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("A right parenthesis is expected."), + 0); if (READsuppress) vs_base[0]= Cnil ; else if (contains_sharp_comma(vs_base[1]) || @@ -1172,7 +1213,10 @@ if (vs_base[2] != Cnil && !READsuppress) if (type_of(vs_base[2]) != t_fixnum || fix(vs_base[2]) != 0) - FEerror("~S is an illegal CHAR-FONT.", 1, vs_base[2]); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("~S is an illegal CHAR-FONT."), + 1, + vs_base[2]); /* assuming that CHAR-FONT-LIMIT is 1 */ vs_popp; vs_popp; @@ -1210,12 +1254,17 @@ int i, n; for (n = 0, i = 1; i < c->s.s_fillp; i++) if (c->s.s_self[i] < '0' || '7' < c->s.s_self[i]) - FEerror("Octal digit expected.", 0); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("Octal digit expected."), + 0); else n = 8*n + c->s.s_self[i] - '0'; vs_base[0] = code_char(n & 0377); } else - FEerror("~S is an illegal character name.", 1, c); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("~S is an illegal character name."), + 1, + c); } void @@ -1267,7 +1316,9 @@ vs_push(read_object(in)); a = backq_car(vs_base[1]); if (a == APPEND || a == NCONC) - FEerror(",at or ,. has appeared in an illegal position.", 0); + Icall_error_handler(sKsimple_reader_error, + make_simple_string(",at or ,. has appeared in an illegal position."), + 0); if (a == QUOTE) { vsp = vs_top; dimcount = 0; @@ -1306,10 +1357,14 @@ L: if (dim >= 0) { if (dimcount > dim) - FEerror("Too many elements in #(...).", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Too many elements in #(...)."), + 0); else { if (dimcount == 0) - FEerror("Cannot fill the vector #().", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Cannot fill the vector #()."), + 0); x = vs_head; for (; dimcount < dim; dimcount++) vs_push(x); @@ -1366,7 +1421,9 @@ } if (dim >= 0) { if (dimcount > dim) - FEerror("Too many elements in #*....", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Too many elements in #*...."), + 0); else { if (dimcount == 0) error("Cannot fill the bit-vector #*."); @@ -1544,11 +1601,15 @@ vs_base[0] = parse_number(token_buffer, token->st.st_fillp, &i, 2); if (vs_base[0] == OBJNULL || i != token->st.st_fillp) - FEerror("Cannot parse the #B readmacro.", 0); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("Cannot parse the #B readmacro."), + 0); if (type_of(vs_base[0]) == t_shortfloat || type_of(vs_base[0]) == t_longfloat) - FEerror("The float ~S appeared after the #B readmacro.", - 1, vs_base[0]); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("The float ~S appeared after the #B readmacro."), + 1, + vs_base[0]); } void @@ -1568,11 +1629,15 @@ vs_base[0] = parse_number(token_buffer, token->st.st_fillp, &i, 8); if (vs_base[0] == OBJNULL || i != token->st.st_fillp) - FEerror("Cannot parse the #O readmacro.", 0); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("Cannot parse the #O readmacro."), + 0); if (type_of(vs_base[0]) == t_shortfloat || type_of(vs_base[0]) == t_longfloat) - FEerror("The float ~S appeared after the #O readmacro.", - 1, vs_base[0]); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("The float ~S appeared after the #O readmacro."), + 1, + vs_base[0]); } void @@ -1592,11 +1657,15 @@ vs_base[0] = parse_number(token_buffer, token->st.st_fillp, &i, 16); if (vs_base[0] == OBJNULL || i != token->st.st_fillp) - FEerror("Cannot parse the #X readmacro.", 0); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("Cannot parse the #X readmacro."), + 0); if (type_of(vs_base[0]) == t_shortfloat || type_of(vs_base[0]) == t_longfloat) - FEerror("The float ~S appeared after the #X readmacro.", - 1, vs_base[0]); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("The float ~S appeared after the #X readmacro."), + 1, + vs_base[0]); } void @@ -1610,9 +1679,14 @@ else if (type_of(vs_base[2]) == t_fixnum) { radix = fix(vs_base[2]); if (radix > 36 || radix < 2) - FEerror("~S is an illegal radix.", 1, vs_base[2]); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("~S is an illegal radix."), + 1, + vs_base[2]); } else - FEerror("No radix was supplied in the #R readmacro.", 0); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("No radix was supplied in the #R readmacro."), + 0); vs_popp; vs_popp; read_constituent(vs_base[0]); @@ -1623,11 +1697,15 @@ vs_base[0] = parse_number(token_buffer, token->st.st_fillp, &i, radix); if (vs_base[0] == OBJNULL || i != token->st.st_fillp) - FEerror("Cannot parse the #R readmacro.", 0); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("Cannot parse the #R readmacro."), + 0); if (type_of(vs_base[0]) == t_shortfloat || type_of(vs_base[0]) == t_longfloat) - FEerror("The float ~S appeared after the #R readmacro.", - 1, vs_base[0]); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("The float ~S appeared after the #R readmacro."), + 1, + vs_base[0]); } void Lsharp_A_reader(){} @@ -1645,13 +1723,19 @@ return; } if (vs_base[2] == Cnil) - FEerror("The #= readmacro requires an argument.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("The #= readmacro requires an argument."), + 0); for (i = 0; i < sharp_eq_context_max; i++) if (eql(sharp_eq_context[i].sharp_index, vs_base[2])) - FEerror("Duplicate definitions for #~D=.", - 1, vs_base[2]); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("Duplicate definitions for #~D=."), + 1, + vs_base[2]); if (sharp_eq_context_max >= SHARP_EQ_CONTEXT_SIZE) - FEerror("Too many #= definitions.", 0); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("Too many #= definitions."), + 0); i = sharp_eq_context_max++; sharp_eq_context[i].sharp_index = vs_base[2]; sharp_eq_context[i].sharp_sharp = OBJNULL; @@ -1660,8 +1744,10 @@ = read_object(vs_base[0]); if (sharp_eq_context[i].sharp_eq == sharp_eq_context[i].sharp_sharp) - FEerror("#~D# is defined by itself.", - 1, sharp_eq_context[i].sharp_index); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("#~D# is defined by itself."), + 1, + sharp_eq_context[i].sharp_index); vs_top = vs_base+1; } @@ -1677,10 +1763,15 @@ vs_base[0] = Cnil; } if (vs_base[2] == Cnil) - FEerror("The ## readmacro requires an argument.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("The ## readmacro requires an argument."), + 0); for (i = 0; ; i++) if (i >= sharp_eq_context_max) - FEerror("#~D# is undefined.", 1, vs_base[2]); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("#~D# is undefined."), + 1, + vs_base[2]); else if (eql(sharp_eq_context[i].sharp_index, vs_base[2])) break; @@ -1817,7 +1908,9 @@ void Ldefault_dispatch_macro() { - FEerror("The default dispatch macro signalled an error.", 0); + Icall_error_handler(sKsimple_reader_error, + make_simple_string("The default dispatch macro signalled an error."), + 0); } /* @@ -1868,8 +1961,10 @@ vs_popp; vs_base[0] = read_object(vs_base[0]); if (type_of(vs_base[0]) != t_fixnum) - FEerror("Cannot make a random-state with the value ~S.", - 1, vs_base[0]); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Cannot make a random-state with the value ~S."), + 1, + vs_base[0]); i = fix(vs_base[0]); vs_base[0] = alloc_object(t_random); vs_base[0]->rnd.rnd_value = i; @@ -1924,8 +2019,10 @@ r = symbol_value(Vreadtable); if (type_of(r) != t_readtable) { Vreadtable->s.s_dbind = copy_readtable(standard_readtable,sLnil); - FEerror("The value of *READTABLE*, ~S, was not a readtable.", - 1, r); + Icall_error_handler(sLsimple_type_error, + make_simple_string("The value of *READTABLE*, ~S, was not a readtable."), + 1, + r); } return(r); } @@ -2237,7 +2334,10 @@ get_string_start_end(strng, start, end, &s, &e); if (type_of(radix) != t_fixnum || fix(radix) < 2 || fix(radix) > 36) - FEerror("~S is an illegal radix.", 1, radix); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal radix."), + 1, + radix); setup_READtable(); while (READtable->rt.rt_self[(unsigned char)strng->st.st_self[s]].rte_chattrib == cat_whitespace && s < e) @@ -2269,7 +2369,10 @@ @(return x `make_fixnum(e)`) CANNOT_PARSE: - FEerror("Cannot parse an integer in the string ~S.", 1, strng); + Icall_error_handler(sKsimple_parse_error, + make_simple_string("Cannot parse an integer in the string ~S."), + 1, + strng); @) @(defun read_byte (binary_input_stream @@ -2429,7 +2532,10 @@ check_type_readtable(&rdtbl); if (rdtbl->rt.rt_self[char_code(dspchr)].rte_macro != dispatch_reader || rdtbl->rt.rt_self[char_code(dspchr)].rte_dtab == NULL) - FEerror("~S is not a dispatch character.", 1, dspchr); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is not a dispatch character."), + 1, + dspchr); rdtbl->rt.rt_self[char_code(dspchr)] .rte_dtab[char_code(subchr)] = fnc; if ('a' <= char_code(subchr) && char_code(subchr) <= 'z') @@ -2447,7 +2553,10 @@ check_type_readtable(&rdtbl); if (rdtbl->rt.rt_self[char_code(dspchr)].rte_macro != dispatch_reader || rdtbl->rt.rt_self[char_code(dspchr)].rte_dtab == NULL) - FEerror("~S is not a dispatch character.", 1, dspchr); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is not a dispatch character."), + 1, + dspchr); if (digitp(char_code(subchr),10) >= 0) @(return Cnil) else @(return `rdtbl->rt.rt_self[char_code(dspchr)] .rte_dtab[char_code(subchr)]`) @@ -2528,8 +2637,11 @@ extra_argument(c) int c; { - FEerror("~S is an extra argument for the #~C readmacro.", - 2, vs_base[2], code_char(c)); + Icall_error_handler(sLsimple_error, + make_simple_string("~S is an extra argument for the #~C readmacro."), + 2, + vs_base[2], + code_char(c)); } diff -uNr TEST.gcl/gcl/o/regexpr.c agcl/agcl/o/regexpr.c --- TEST.gcl/gcl/o/regexpr.c Wed Jul 24 05:35:44 2002 +++ agcl/agcl/o/regexpr.c Mon Nov 4 17:54:14 2002 @@ -27,7 +27,10 @@ void gcl_regerror(char *s) { - FEerror("Regexp Error: ~a",1,make_simple_string(s)); + Icall_error_handler(sLsimple_error, + make_simple_string("Regexp Error: ~A."), + 1, + make_simple_string(s)); } #undef endp #include "regexp.c" @@ -105,7 +108,9 @@ if (start < 0 || end > string->st.st_fillp || start > end) - FEerror("Bad start or end",0); + Icall_error_handler(sLsimple_error, + make_simple_string("Bad start or end"), + 0); len = pattern->ust.ust_fillp; if (len==0) { /* trivial case of empty pattern */ diff -uNr TEST.gcl/gcl/o/run_process.c agcl/agcl/o/run_process.c --- TEST.gcl/gcl/o/run_process.c Fri Nov 1 05:09:34 2002 +++ agcl/agcl/o/run_process.c Mon Nov 4 16:59:30 2002 @@ -304,13 +304,11 @@ run_process(object_to_string(vs_base[0]), argv); } -void siLmake_socket_pair() { make_socket_pair(); } -void init_socket_function() { make_si_function("MAKE-SOCKET-STREAM", siLmake_socket_stream); diff -uNr TEST.gcl/gcl/o/sequence.d agcl/agcl/o/sequence.d --- TEST.gcl/gcl/o/sequence.d Tue Oct 15 21:32:01 2002 +++ agcl/agcl/o/sequence.d Mon Nov 4 17:54:14 2002 @@ -311,8 +311,13 @@ } ILLEGAL_START_END: - FEerror("~S and ~S are illegal as :START and :END~%\ -for the sequence ~S.", 3, start, end, sequence); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S and ~S are illegal as :START and :END~%\ + for the sequence ~S."), + 3, + start, + end, + sequence); @) void diff -uNr TEST.gcl/gcl/o/sfasl.c agcl/agcl/o/sfasl.c --- TEST.gcl/gcl/o/sfasl.c Fri Nov 1 05:09:34 2002 +++ agcl/agcl/o/sfasl.c Mon Nov 4 17:54:14 2002 @@ -46,7 +46,7 @@ struct node * find_sym(); int node_compare(); #ifndef _WIN32 -void *malloc(); +char *malloc(); char *bsearch(); #endif @@ -144,7 +144,9 @@ HEADER_SEEK(fp); if(!fread((char *)&fileheader, sizeof(struct filehdr), 1, fp)) - FEerror("Could not get the header",0,0); + Icall_error_handler(sLsimple_error, + make_simple_string("Could not get the header"), + 0); nsyms = NSYMS(fileheader); #ifdef COFF @@ -202,15 +204,18 @@ #endif {int ii=0; if (!fread((char *)&ii,sizeof(int),1,fp)) - {FEerror("The string table of this file did not have any length",0, - 0);} + {Icall_error_handler(sLsimple_error, + make_simple_string("The string table of this file did not have any length"), + 0);} fseek(fp,-4,1); /* at present the string table is located just after the symbols */ my_string_table=OUR_ALLOCA((unsigned int)ii); dprintf( string table leng = %d, ii); if(ii!=fread(my_string_table,1,ii,fp)) - FEerror("Could not read whole string table",0,0) ; + Icall_error_handler(sLsimple_error, + make_simple_error("Could not read whole string table"), + 0) ; } #endif #ifdef SEEK_TO_END_OFILE @@ -255,7 +260,9 @@ dprintf( code size %d , datasize+textsize+bsssize + extra_bss); if (fseek(fp,N_TXTOFF(fileheader) ,0) < 0) - FEerror("file seek error",0,0); + Icall_error_handler(sLsimple_error, + make_simple_string("file seek error"), + 0); fread(the_start, textsize + datasize, 1, fp); dprintf(read into memory text +data %d bytes, textsize + datasize); /* relocate the actual loaded text */ @@ -419,7 +426,9 @@ strcmp(sym->n_name,"_ptrgl")==0) {struct syment* s = get_symbol("._ptrgl",TEXT_NSCN,sym_table,length); - if (s ==0) FEerror("bad glue",0,0); + if (s ==0) Icall_error_handler(sLsimple_serror, + make_simple_string("bad glue"), + 0); sym->n_value = next_bss ; ptrgl_offset = next_bss; ptrgl_text = s->n_value; @@ -629,7 +638,9 @@ }} - else{FEerror("symbol table not loaded",0,0);}} + else{Icall_error_handler(sLsimple_error, + make_simple_string("symbol table not loaded"), + 0);}} /* include the machine independent stuff */ #include "sfasli.c" diff -uNr TEST.gcl/gcl/o/sfaslbfd.c agcl/agcl/o/sfaslbfd.c --- TEST.gcl/gcl/o/sfaslbfd.c Wed Oct 23 06:38:21 2002 +++ agcl/agcl/o/sfaslbfd.c Mon Nov 4 17:54:14 2002 @@ -223,13 +223,21 @@ coerce_to_filename(faslfile, filename); if (!(b=bfd_openr(filename,0))) - FEerror("Cannot open bfd"); + Icall_error_handler(sLsimple_error, + make_simple_string("Cannot open bfd"), + 0); if ((myerr=bfd_get_error()) && myerr!=3) - FEerror("Unknown bfd error code on openr"); + Icall_error_handler(sLsimple_error, + make_simple_string("Unknown bfd error code on openr"), + 0); if (!bfd_check_format(b,bfd_object)) - FEerror("Unknown bfd format"); + Icall_error_handler(sLsimple_error, + make_simple_string("Unknown bfd format"), + 0); if ((myerr=bfd_get_error()) && myerr!=3) - FEerror("Unknown bfd error code on check_format"); + Icall_error_handler(sLsimple_error, + make_simple_string("Unknown bfd error code on check_format"), + 0); bfd_set_error(0); current=NULL; @@ -277,10 +285,14 @@ } if ((u=bfd_get_symtab_upper_bound(b))<0) - FEerror("Cannot get symtab uppoer bound"); + Icall_error_handler(sLsimple_error, + make_simple_string("Cannot get symtab upper bound"), + 0); q=(asymbol **)alloca(u); if ((v=bfd_canonicalize_symtab(b,q))<0) - FEerror("cannot canonicalize symtab"); + Icall_error_handler(sLsimple_error, + make_simple_string("Cannot canonicalize symtab."), + 0); for (u=0;utype!=bfd_link_hash_defined) - FEerror("Undefined symbol"); + Icall_error_handler(sLsimple_error, + make_simple_string("Undefined BFD symbol."), + 0); if (h->u.def.section) { q[u]->value=h->u.def.value+h->u.def.section->vma; q[u]->flags|=BSF_WEAK; } else - FEerror("Symbol without section"); + Icall_error_handler(sLsimple_error, + make_simple_string("BFD Symbol without section."), + 0); } @@ -315,7 +331,9 @@ void *v=alloca(memory->cfd.cfd_size); if (!v) - FEerror("Cannot alloca for bfd"); + Icall_error_handler(sLsimple_error, + make_simple_string("Cannot alloca for BFD."), + 0); for (s=b->sections;s;s=s->next) { @@ -326,7 +344,9 @@ if (!bfd_get_relocated_section_contents(b,&link_info,&link_order, v,0,q)) - FEerror("Cannot get relocated section contents\n"); + Icall_error_handler(sLsimple_error, + make_simple_string("Cannot get relocated section contents."), + 0); memcpy((void *)s->output_section->vma,v,s->_raw_size); diff -uNr TEST.gcl/gcl/o/sfasli.c agcl/agcl/o/sfasli.c --- TEST.gcl/gcl/o/sfasli.c Sun Oct 27 16:35:06 2002 +++ agcl/agcl/o/sfasli.c Mon Nov 4 17:54:14 2002 @@ -35,34 +35,50 @@ bfd_init(); if (!(bself=bfd_openr(kcl_self,0))) - FEerror("Cannot open self\n"); + Icall_error_handler(sLsimple_error, + make_simple_string("Cannot open self."), + 0); if (!bfd_check_format(bself,bfd_object)) - FEerror("I'm not an object"); + Icall_error_handler(sLsimple_error, + make_simple_string("I'm not an object! Don't treat me like one!."), + 0); /* if (link_info.hash) */ /* bfd_link_hash_table_free(bself,link_info.hash); */ if (!(link_info.hash = bfd_link_hash_table_create (bself))) - FEerror("Cannot make hash table"); + Icall_error_handler(sLsimple_error, + make_simple_string("Cannot make hash table"), + 0); if (!bfd_link_add_symbols(bself,&link_info)) - FEerror("Cannot add self symbols\n"); + Icall_error_handler(sLsimple_error, + make_simple_string("Cannot add self symbols."), + 0); if ((u=bfd_get_symtab_upper_bound(bself))<0) - FEerror("Cannot get self's symtab upper bound"); + Icall_error_handler(sLsimple_error, + make_simple_string("Cannot get self's symtab upper bound"), + 0); #ifdef HAVE_ALLOC q=(asymbol **)alloca(u); #else q=(asymbol **)malloc(u); #endif if ((v=bfd_canonicalize_symtab(bself,q))<0) - FEerror("Cannot canonicalize self's symtab"); + Icall_error_handler(sLsimple_error, + make_simple_string("Cannot canonicalize self's symtab."), + 0); for (u=0;uname,"@@"))) { struct bfd_link_hash_entry *h; *c=0; if (!(h=bfd_link_hash_lookup(link_info.hash,q[u]->name,true,true,true))) - FEerror("Cannot make new hash entry"); + Icall_error_handler(sLsimple_error, + make_simple_string("Cannot make new hash entry"), + 0); h->type=bfd_link_hash_defined; if (!q[u]->section) - FEerror("Symbol is missing section"); + Icall_error_handler(sLsimple_error, + make_simple_string("BFD Symbol is missing section"), + 0); h->u.def.value=q[u]->value+q[u]->section->vma; h->u.def.section=q[u]->section; *c='@'; @@ -100,10 +116,15 @@ #endif if (system(command) != 0) #ifdef STAND - FEerror("The rsym command %s failed .",1,command); + Icall_error_handler(sLsimple_error, + make_simple_string("The rsym command %s failed."), + 1, + command); #else - FEerror("The rsym command ~a failed .",1, - make_simple_string(command)); + Icall_error_handler(sLsimple_error, + make_simple_string("The rsym command ~a failed."), + 1, + make_simple_string(command)); #endif read_special_symbols(tmpfile1); unlink(tmpfile1); diff -uNr TEST.gcl/gcl/o/sgbc.c agcl/agcl/o/sgbc.c --- TEST.gcl/gcl/o/sgbc.c Sun Oct 27 21:39:23 2002 +++ agcl/agcl/o/sgbc.c Mon Nov 4 17:54:14 2002 @@ -1229,7 +1229,9 @@ #endif if(mprotect(pagetochar(pbeg),n*PAGESIZE, (writable & SGC_WRITABLE ? PROT_READ_WRITE : PROT_READ))) - FEerror("Couldn't protect",0); + Icall_error_handler(sKsimple_storage_condition, + make_simple_string("Couldn't protect"), + 0); } @@ -1353,7 +1355,9 @@ void system_error(void) { - FEerror("System error",0); + Icall_error_handler(sKsimple_storage_condition, + make_simple_string("System error"), + 0); } diff -uNr TEST.gcl/gcl/o/sockets.c agcl/agcl/o/sockets.c --- TEST.gcl/gcl/o/sockets.c Wed Jul 24 05:35:44 2002 +++ agcl/agcl/o/sockets.c Mon Nov 4 17:54:14 2002 @@ -388,7 +388,9 @@ int downcase ; int do_end_quote = 0; if(type_of(str)!=t_string) - FEerror("Must be given string with fill pointer",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Must be given a string with a fill pointer."), + 0); if (t==t_symbol) downcase=1; else downcase=0; @@ -466,7 +468,10 @@ case t_bignum: goto FAIL; default: - FEerror("Bad type for print_string ~s",1,x); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Bad type for print-string ~s"), + 1, + x); } if(do_end_quote) PUSH('"'); str->st.st_fillp += (xx - &(str->st.st_self[fp])); @@ -482,7 +487,9 @@ void not_defined_for_os() -{ FEerror("Function not defined for this operating system",0);} +{ Icall_error_handler(sLsimple_error, + make_simple_string("Not supported on this operating system, yet."), + 0);} DEFUN("SET-SIGIO-FOR-FD",object,fSset_sigio_for_fd,SI,1,1,NONE,OI,OO,OO,OO,"") @@ -556,13 +563,19 @@ void write_timeout_error(s) char *s; -{FEerror("Write timeout: ~s",1,make_simple_string(s)); +{Icall_error_handler(sLsimple_error, + make_simple_string("write timed out: ~s"), + 1, + make_simple_string(s)); } void connection_failure(s) char *s; -{FEerror("Connect failure: ~s",1,make_simple_string(s)); +{Icall_error_handler(sLsimple_error, + make_simple_string("Connect failure: ~s."), + 1, + make_simple_string(s)); } diff -uNr TEST.gcl/gcl/o/string.d agcl/agcl/o/string.d --- TEST.gcl/gcl/o/string.d Sat Oct 5 20:34:15 2002 +++ agcl/agcl/o/string.d Mon Nov 4 17:54:14 2002 @@ -260,8 +260,13 @@ return; E: - FEerror("~S and ~S are illegal as :START and :END~%\ -for the string ~S.", 3, start, end, string); + Icall_error_handler(sLsimple_error, + make_simple_string("~S and ~S are illegal as :START and :END~%\ + for the string ~S."), + 3, + start, + end, + string); } @(defun string_eq (string1 string2 @@ -452,7 +457,10 @@ return(FALSE); default: - FEerror("~S is not a sequence.", 1, char_bag); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is not a sequence."), + 1, + char_bag); return(FALSE); } } diff -uNr TEST.gcl/gcl/o/structure.c agcl/agcl/o/structure.c --- TEST.gcl/gcl/o/structure.c Tue Sep 24 21:01:46 2002 +++ agcl/agcl/o/structure.c Mon Nov 4 17:54:14 2002 @@ -42,7 +42,9 @@ { if (x==y) return 1; if (type_of(x)!= t_structure || type_of(y)!=t_structure) - FEerror("bad call to structure_subtypep",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Bad call to structure_subtypep."), + 0); {if (S_DATA(y)->included == Cnil) return 0; while ((x=S_DATA(x)->includes) != Cnil) { if (x==y) return 1;} @@ -51,7 +53,9 @@ static void bad_raw_type(void) -{ FEerror("Bad raw struct type",0);} +{ Icall_error_handler(sLsimple_type_error, + make_simple_string("Bad raw struct type"), + 0);} object @@ -91,7 +95,9 @@ check_type_structure(x); def=x->str.str_def; if(n>= S_DATA(def)->length) - FEerror("Structure ref out of bounds",0); + Icall_error_handler(sLsimple_error, + make_simple_string("Structure ref out of bounds."), + 0); vs_base[0]=structure_ref(x,x->str.str_def,n); vs_top=vs_base+1; } @@ -114,7 +120,9 @@ #ifdef SGC /* make sure the structure header is on a writable page */ - if (x->d.m) FEerror("bad gc field",0); else x->d.m = 0; + if (x->d.m) Icall_error_handler(sKsimple_storage_condition, + make_simple_string("bad gc field"), + 0); else x->d.m = 0; #endif s_pos= & SLOT_POS(x->str.str_def,0); @@ -192,8 +200,10 @@ COERCE_DEF(name); if (type_of(name)!=t_structure || (def=S_DATA(name))->length != --narg) - FEerror("Bad make_structure args for type ~a",1, - base[0]); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Bad make-structure args for type ~a"), + 1, + base[0]); x->str.str_def = name; x->str.str_self = NULL; size=S_DATA(name)->size; @@ -302,14 +312,23 @@ check_arg(3); if (type_of(vs_base[1]) != t_fixnum || fix(vs_base[1]) < 0) - FEerror("~S is not a non-negative fixnum.", 1, vs_base[1]); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is not a non-negative fixnum."), + 1, + vs_base[1]); if (type_of(vs_base[0]) != t_cons) - FEerror("~S is not a cons.", 1, vs_base[0]); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is not a cons."), + 1, + vs_base[0]); for (i = fix(vs_base[1]), l = vs_base[0]; i > 0; --i) { l = l->c.c_cdr; if (endp(l)) - FEerror("The offset ~S is too big.", 1, vs_base[1]); + Icall_error_handler(sLsimple_error, + make_simple_string("The offset ~S is too big."), + 1, + vs_base[1]); } take_care(vs_base[2]); l->c.c_car = vs_base[2]; @@ -330,14 +349,22 @@ check_arg(2); if (type_of(vs_base[0]) != t_fixnum || fix(vs_base[0]) < 0) - FEerror("~S is not a non-negative fixnum.", 1, vs_base[0]); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is not a non-negative fixnum."), + 1, + vs_base[0]); if (type_of(vs_base[1]) != t_cons) - FEerror("~S is not a cons.", 1, vs_base[1]); - + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is not a cons."), + 1, + vs_base[1]); for (i = fix(vs_base[0]), l = vs_base[1]; i > 0; --i) { l = l->c.c_cdr; if (endp(l)) - FEerror("The offset ~S is too big.", 1, vs_base[0]); + Icall_error_handler(sLsimple_type_error, + make_simple_string("The offset ~S is too big."), + 1, + vs_base[0]); } vs_base[0] = l->c.c_car; diff -uNr TEST.gcl/gcl/o/symbol.d agcl/agcl/o/symbol.d --- TEST.gcl/gcl/o/symbol.d Thu Oct 10 04:51:59 2002 +++ agcl/agcl/o/symbol.d Mon Nov 4 17:54:14 2002 @@ -253,7 +253,10 @@ return(l->c.c_cdr->c.c_car); } if(l==Cnil) return deflt; - FEerror("Bad plist ~a",1,place); + Icall_error_handler(sLcell_error, + make_simple_string("Bad plist ~a"), + 1, + place); return Cnil; } @@ -285,7 +288,11 @@ return(p); } } - if(l!=Cnil) FEerror("Bad plist ~a",1,p); + if(l!=Cnil) + Icall_error_handler(sLcell_error, + make_simple_string("Bad plist ~a"), + 1, + p); l = make_cons(v, p); vs_push(l); l = make_cons(i, l); @@ -631,7 +638,10 @@ odd_plist(place) object place; { - FEerror("The length of the property-list ~S is odd.", 1, place); + Icall_error_handler(sLsimple_error, + make_simple_string("The length of the property-list ~S is odd."), + 1, + place); } diff -uNr TEST.gcl/gcl/o/toplevel.c agcl/agcl/o/toplevel.c --- TEST.gcl/gcl/o/toplevel.c Tue Sep 24 21:01:46 2002 +++ agcl/agcl/o/toplevel.c Mon Nov 4 17:54:14 2002 @@ -48,7 +48,10 @@ if (endp(args) || endp(MMcdr(args))) FEtoo_few_argumentsF(args); if (MMcadr(args) != Cnil && type_of(MMcadr(args)) != t_cons) - FEerror("~S is an illegal lambda-list.", 1, MMcadr(args)); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is an illegal lambda-list."), + 1, + MMcadr(args)); name = MMcar(args); if (type_of(name) != t_symbol) not_a_symbol(name); @@ -57,7 +60,10 @@ if (symbol_value(sSAinhibit_macro_specialA) != Cnil) name->s.s_sfdef = NOT_SPECIAL; } else if (symbol_value(sSAinhibit_macro_specialA) != Cnil) - FEerror("~S, a special form, cannot be redefined.", 1, name); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S, a special form, cannot be redefined."), + 1, + name); } if (name->s.s_hpack == lisp_package && name->s.s_gfdef != OBJNULL && initflag) { @@ -103,7 +109,10 @@ check_arg(1); check_type_symbol(&vs_base[0]); if ((enum stype)vs_base[0]->s.s_stype == stp_constant) - FEerror("~S is a constant.", 1, vs_base[0]); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is a constant."), + 1, + vs_base[0]); vs_base[0]->s.s_stype = (short)stp_special; } @@ -113,9 +122,10 @@ check_arg(2); check_type_symbol(&vs_base[0]); if ((enum stype)vs_base[0]->s.s_stype == stp_special) - FEerror( - "The argument ~S to DEFCONSTANT is a special variable.", - 1, vs_base[0]); + Icall_error_handler(sLsimple_type_error, + make_simple_string("The argument ~S to DEFCONSTANT is a special variable."), + 1, + vs_base[0]); vs_base[0]->s.s_stype = (short)stp_constant; vs_base[0]->s.s_dbind = vs_base[1]; vs_popp; @@ -150,7 +160,9 @@ void Fdeclare(object arg) { - FEerror("DECLARE appeared in an invalid position.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("DECLARE appeared in an invalid position."), + 0); } void @@ -181,12 +193,16 @@ vs = vs_base; for (args=MMcdr(args); !endp(args); args=MMcdr(args), vs++){ if (vs >= vs_top) - FEerror("Too many return values.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Too many return values."), + 0); if (ifuncall2(sLtypep, *vs, MMcar(args)) == Cnil) FEwrong_type_argument(MMcar(args), *vs); } if (vs < vs_top) - FEerror("Too few return values.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Too few return values."), + 0); } else { if (ifuncall2(sLtypep, vs_base[0], args) == Cnil) FEwrong_type_argument(args, vs_base[0]); diff -uNr TEST.gcl/gcl/o/typespec.c agcl/agcl/o/typespec.c --- TEST.gcl/gcl/o/typespec.c Mon Oct 14 07:24:43 2002 +++ agcl/agcl/o/typespec.c Mon Nov 4 17:54:14 2002 @@ -282,8 +282,11 @@ void check_type(object x, int t) {if (type_of(x) !=t) - FEerror("~s is not a ~a",2, - x,make_simple_string(tm_table[t].tm_name +1)); + Icall_error_handler(sLtype_error, + make_simple_string("~s is not a ~a"), + 2, + x, + make_simple_string(tm_table[t].tm_name +1)); } @@ -488,6 +491,45 @@ #ifdef ANSI_COMMON_LISP /* New ansi types */ +DEF_ORDINARY("ARITHMETIC-ERROR",sLarithmetic_error,LISP,""); +DEF_ORDINARY("CELL-ERROR",sLcell_error,LISP,""); +DEF_ORDINARY("CONDITION",sLcondition,LISP,""); +DEF_ORDINARY("CONTROL-ERROR",sLcontrol_error,LISP,""); +DEF_ORDINARY("DIVISION-BY-ZERO",sLdivision_by_zero,LISP,""); +DEF_ORDINARY("END-OF-FILE",sLend_of_file,LISP,""); +DEF_ORDINARY("ERROR",sLerror,LISP,""); +DEF_ORDINARY("FILE-ERROR",sLfile_error,LISP,""); +DEF_ORDINARY("FLOATING-POINT-INEXACT",sLfloating_point_inexact,LISP,""); +DEF_ORDINARY("FLOATING-POINT-INVALID-OPERATION",sLfloating_point_invalid_operation,LISP,""); +DEF_ORDINARY("FLOATING-POINT-OVERFLOW",sLfloating_point_overflow,LISP,""); +DEF_ORDINARY("FLOATING-POINT-UNDERFLOW",sLfloating_point_underflow,LISP,""); +DEF_ORDINARY("PACKAGE-ERROR",sLpackage_error,LISP,""); +DEF_ORDINARY("PARSE-ERROR",sLparse_error,LISP,""); +DEF_ORDINARY("PRINT-NOT-READABLE",sLprint_not_readable,LISP,""); +DEF_ORDINARY("PROGRAM-ERROR",sLprogram_error,LISP,""); +DEF_ORDINARY("READER-ERROR",sLreader_error,LISP,""); +DEF_ORDINARY("SERIOUS-CONDITION",sLserious_condition,LISP,""); +DEF_ORDINARY("SIMPLE-CONDITION",sLsimple_condition,LISP,""); +DEF_ORDINARY("SIMPLE-ERROR",sLsimple_error,LISP,""); +DEF_ORDINARY("SIMPLE-TYPE-ERROR",sLsimple_type_error,LISP,""); +DEF_ORDINARY("SIMPLE-WARNING",sLsimple_warning,LISP,""); +DEF_ORDINARY("STORAGE-CONDITION",sLstorage_condition,LISP,""); +DEF_ORDINARY("STREAM-ERROR",sLstream_error,LISP,""); +DEF_ORDINARY("STYLE-WARNING",sLstyle_warning,LISP,""); +DEF_ORDINARY("TYPE-ERROR",sLtype_error,LISP,""); +DEF_ORDINARY("UNBOUND-SLOT",sLunbound_slot,LISP,""); +DEF_ORDINARY("UNBOUND-VARIABLE",sLunbound_variable,LISP,""); +DEF_ORDINARY("UNDEFINED-FUNCTION",sLundefined_function,LISP,""); +DEF_ORDINARY("WARNING",sLwarning,LISP,""); + +DEF_ORDINARY("SIMPLE-STORAGE-CONDITION",sKsimple_storage_condition,KEYWORD,""); +DEF_ORDINARY("SIMPLE-PROGRAM-ERROR",sKsimple_program_error,KEYWORD,""); +DEF_ORDINARY("SIMPLE-CONTROL-ERROR",sKsimple_control_error,KEYWORD,""); +DEF_ORDINARY("SIMPLE-READER-ERROR",sKsimple_reader_error,KEYWORD,""); +DEF_ORDINARY("SIMPLE-PACKAGE-ERROR",sKsimple_package_error,KEYWORD,""); +DEF_ORDINARY("SIMPLE-FP-OVERFLOW",sKsimple_fp_overflow,KEYWORD,""); +DEF_ORDINARY("SIMPLE-PARSE-ERROR",sKsimple_parse_error,KEYWORD,""); + DEF_ORDINARY("METHOD-COMBINATION",sLmethod_combination,LISP,""); DEF_ORDINARY("ARITHMETIC-ERROR",sLarithmetic_error,LISP,""); DEF_ORDINARY("BASE-CHAR",sLbase_char,LISP,""); diff -uNr TEST.gcl/gcl/o/unexec.c agcl/agcl/o/unexec.c --- TEST.gcl/gcl/o/unexec.c Fri Nov 1 05:09:34 2002 +++ agcl/agcl/o/unexec.c Mon Nov 4 16:59:30 2002 @@ -366,7 +366,6 @@ * * driving logic. */ -void unexec (char *new_name, char *a_name, unsigned int data_start, unsigned int bss_start, unsigned int entry_address) { int new, a_out = -1; diff -uNr TEST.gcl/gcl/o/unixfasl.c agcl/agcl/o/unixfasl.c --- TEST.gcl/gcl/o/unixfasl.c Mon Sep 23 16:02:10 2002 +++ agcl/agcl/o/unixfasl.c Mon Nov 4 17:54:14 2002 @@ -154,7 +154,10 @@ /* If the file is smaller than the space asked for, typically the file is an invalid object file */ if (file_len(fp)*4 < memory->cfd.cfd_size) - FEerror("Invalid object file stream: ~a",1,faslfile); + Icall_error_handler(sLsimple_error, + make_simple_string("Invalid object file stream: ~A"), + 1, + faslfile); memory->cfd.cfd_start = ALLOC_ALIGNED(alloc_contblock, memory->cfd.cfd_size,sizeof(double)); @@ -230,8 +233,9 @@ #endif if (system(command) != 0) - FEerror("The linkage editor failed.", 0); - + Icall_error_handler(sLsimple_error, + make_simple_string("The linkage editor failed."), + 0); tempfile = make_simple_string(tempfilename); vs_push(tempfile); tempfile = open_stream(tempfile, smm_input, Cnil, sKerror); @@ -283,7 +287,9 @@ faslink(object faslfile, object ldargstring) { #if defined(__linux__) && defined(__ELF__) - FEerror("faslink() not supported for ELF yet",0); + Icall_error_handler(sLsimple_error, + make_simple_string("faslink() not supported for ELF yet"), + 0); return 0; #else struct exec header, faslheader; @@ -310,7 +316,9 @@ tempfilename); if (system(command) != 0) - FEerror("The linkage editor failed.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("The linkage editor failed."), + 0); fp = fopen(tempfilename, "r"); setbuf(fp, buf); @@ -353,8 +361,9 @@ if(symbol_value(sLAload_verboseA)!=Cnil) printf("start address -T %x ",memory->cfd.cfd_start); if (system(command) != 0) - FEerror("The linkage editor failed.", 0); - + Icall_error_handler(sLsimple_error, + make_simple_string("The linkage editor failed."), + 0); tempfile = make_simple_string(tempfilename); vs_push(tempfile); tempfile = open_stream(tempfile, smm_input, Cnil, sKerror); diff -uNr TEST.gcl/gcl/o/unixfsys.c agcl/agcl/o/unixfsys.c --- TEST.gcl/gcl/o/unixfsys.c Tue Sep 24 00:18:07 2002 +++ agcl/agcl/o/unixfsys.c Mon Nov 4 17:54:14 2002 @@ -74,14 +74,18 @@ static char dev_name[64]; if (stat(dotdot+(16-n)*3, &st) < 0) - FEerror("Can't get the current working directory.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Can't get the current working directory."), + 0); ino = st.st_ino; if (ino == 2) goto ROOT; getwd1(n+1); fp = fopen(dotdot+(16-n-1)*3, "r"); if (fp == NULL) - FEerror("Can't get the current working directory.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Can't get the current working directory."), + 0); setbuf(fp, buf); fread(&dir, sizeof(struct direct), 1, fp); fread(&dir, sizeof(struct direct), 1, fp); @@ -92,7 +96,9 @@ goto FOUND; } fclose(fp); - FEerror("Can't get the current working directory.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Can't get the current working directory."), + 0); FOUND: fclose(fp); @@ -104,7 +110,9 @@ ROOT: fp = fopen("/etc/mnttab", "r"); if (fp == NULL) - FEerror("Can't get the current working directory.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Can't get the current working directory."), + 0); setbuf(fp, buf); for (;;) { if (fread(&mnt, sizeof(struct mnttab), 1, fp) <= 0) @@ -231,7 +239,10 @@ pwent = (n==1 ? getpwuid(getuid()) : getpwnam(name)); if (pwent==0 || ((m = strlen(pwent->pw_dir)) && (m + namestring->st.st_fillp -n) >= MAXPATHLEN -16)) - {FEerror("Can't expand pathname ~a", 1,namestring);} + {Icall_error_handler(sLsimple_error, + make_simple_string("Can't expand pathname ~a"), + 1, + namestring);} bcopy(pwent->pw_dir,p,m); bcopy(namestring->st.st_self+n,p+m,namestring->st.st_fillp-n); p[m+namestring->st.st_fillp-n]=0;} @@ -239,7 +250,10 @@ #endif {if (namestring->st.st_fillp >= MAXPATHLEN - 16) { vs_push(namestring); - FEerror("Too long filename: ~S.", 1, namestring);} + Icall_error_handler(sLsimple_error, + make_simple_string("Filename too long: ~S."), + 1, + namestring);} bcopy(namestring->st.st_self,p,namestring->st.st_fillp); p[namestring->st.st_fillp]=0;} #ifdef FIX_FILENAME @@ -280,7 +294,10 @@ q[0]=0; getwd(current_directory); if (chdir(filename) < 0) - FEerror("Cannot get the truename of ~S.", 1, pathname); + Icall_error_handler(sLsimple_error, + make_simple_string("Cannot get the truename of ~S."), + 1, + pathname); p = getwd(directory); if (p[1]==':' && p[2]=='\\' && p[3]==0) p[2]=0; q[0]=current; @@ -291,7 +308,10 @@ *q++ = '\0'; getwd(current_directory); if (chdir(filename) < 0) - FEerror("Cannot get the truename of ~S.", 1, pathname); + Icall_error_handler(sLsimple_error, + make_simple_string("Cannot get the truename of ~S."), + 1, + pathname); p = getwd(directory); } if (p[0] == '/' && p[1] == '\0') { @@ -395,8 +415,11 @@ coerce_to_filename(vs_base[1], newfilename); #ifdef HAVE_RENAME if (rename(filename, newfilename) < 0) - FEerror("Cannot rename the file ~S to ~S.", - 2, vs_base[0], vs_base[1]); + Icall_error_handler(sLsimple_error, + make_simple_string("Cannot rename the file ~S to ~S."), + 2, + vs_base[0], + vs_base[1]); #else sprintf(command, "mv %s %s", filename, newfilename); system(command); @@ -441,7 +464,10 @@ check_type_or_pathname_string_symbol_stream(&path); coerce_to_filename(path, filename); if (unlink(filename) < 0) - FEerror("Cannot delete the file ~S.", 1, path); + Icall_error_handler(sLsimple_error, + make_simple_string("Cannot delete the file ~S."), + 1, + path); path = Ct; RETURN1(path); } @@ -608,7 +634,10 @@ fp = fopen(filename, "r"); if (fp == NULL) { vs_push(make_simple_string(filename)); - FEerror("Can't open the directory ~S.", 1, vs_head); + Icall_error_handler(sLsimple_error, + make_simple_string("Can't open the directory ~S."), + 1, + vs_head); } setbuf(fp, iobuffer); fread(&dir, sizeof(struct direct), 1, fp); @@ -673,7 +702,10 @@ fp = fopen(filename, "r"); if (fp == NULL) { vs_push(make_simple_string(filename)); - FEerror("Can't open the directory ~S.", 1, vs_head); + Icall_error_handler(sLsimple_error, + make_simple_string("Can't open the directory ~S."), + 1, + vs_head); } setbuf(fp, iobuffer); fread(&dir, sizeof(struct direct), 1, fp); @@ -767,8 +799,10 @@ coerce_to_filename(vs_base[0], filename); if (chdir(filename) < 0) - FEerror("Can't change the current directory to ~S.", - 1, vs_base[0]); + Icall_error_handler(sLsimple_error, + make_simple_string("Can't change the current directory to ~S."), + 1, + vs_base[0]); } void diff -uNr TEST.gcl/gcl/o/unixsys.c agcl/agcl/o/unixsys.c --- TEST.gcl/gcl/o/unixsys.c Tue Sep 10 05:35:15 2002 +++ agcl/agcl/o/unixsys.c Mon Nov 4 17:54:14 2002 @@ -66,7 +66,10 @@ check_arg(1); check_type_string(&vs_base[0]); if (vs_base[0]->st.st_fillp >= 32768) - FEerror("Too long command line: ~S.", 1, vs_base[0]); + Icall_error_handler(sLsimple_error, + make_simple_string("Too long command line: ~S."), + 1, + vs_base[0]); for (i = 0; i < vs_base[0]->st.st_fillp; i++) command[i] = vs_base[0]->st.st_self[i]; command[i] = '\0'; diff -uNr TEST.gcl/gcl/o/unixtime.c agcl/agcl/o/unixtime.c --- TEST.gcl/gcl/o/unixtime.c Sun Oct 27 16:35:06 2002 +++ agcl/agcl/o/unixtime.c Mon Nov 4 17:54:14 2002 @@ -116,7 +116,10 @@ check_arg(1); check_type_or_rational_float(&vs_base[0]); if (number_minusp(vs_base[0]) == TRUE) - FEerror("~S is not a non-negative number.", 1, vs_base[0]); + Icall_error_handler(sLsimple_type_error, + make_simple_string("~S is not a non-negative number."), + 1, + vs_base[0]); vs_base[0]=number_times(vs_base[0],make_fixnum(1000000)); Lround(); z = vs_base[0]; diff -uNr TEST.gcl/gcl/o/usig.c agcl/agcl/o/usig.c --- TEST.gcl/gcl/o/usig.c Sun Oct 27 22:06:42 2002 +++ agcl/agcl/o/usig.c Mon Nov 4 17:54:14 2002 @@ -137,14 +137,18 @@ sigfpe1(void) { gcl_signal(SIGFPE, sigfpe1); - FEerror("Floating-point exception.", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Floating-point exception."), + 0); } void sigpipe(void) { gcl_signal(SIGPIPE, sigpipe); perror(""); - FEerror("Broken pipe", 0); + Icall_error_handler(sLsimple_error, + make_simple_string("Broken pipe"), + 0); } diff -uNr TEST.gcl/gcl/o/usig2.c agcl/agcl/o/usig2.c --- TEST.gcl/gcl/o/usig2.c Wed Jul 31 05:13:52 2002 +++ agcl/agcl/o/usig2.c Mon Nov 4 17:54:14 2002 @@ -159,7 +159,10 @@ (signo,safety) { if (signo > sizeof(safety_required)) - {FEerror("Illegal signo:~a.",1,make_fixnum(signo));} + {Icall_error_handler(sLsimple_type_error, + make_simple_string("Illegal signo: ~a."), + 1, + make_fixnum(signo));} if (safety >=0) safety_required[signo] = safety; return make_fixnum(safety_required[signo]) ; } diff -uNr TEST.gcl/gcl/o/utils.c agcl/agcl/o/utils.c --- TEST.gcl/gcl/o/utils.c Sat Oct 26 18:18:13 2002 +++ agcl/agcl/o/utils.c Mon Nov 4 17:54:14 2002 @@ -12,7 +12,10 @@ object IisSymbol(object f) { if (type_of(f) != t_symbol) - { FEerror("Not a symbol ~s",1,f); } + { Icall_error_handler(sLsimple_type_error, + make_simple_string("Not a symbol ~s"), + 1, + f); } return f; } @@ -21,7 +24,10 @@ { IisSymbol(f); if (f->s.s_gfdef ==0) - { FEerror("Not a fboundp ~s",1,f);} + { Icall_error_handler(sLsimple_type_error, + make_simple_string("Not a fboundp ~s"), + 1, + f);} return f; } @@ -34,7 +40,10 @@ |TS(t_string))) return f; else - { FEerror("Not an array ~s",1,f); return f; + { Icall_error_handler(sLsimple_type_error, + make_simple_string("Not an array ~s"), + 1, + f); return f; } } @@ -43,13 +52,18 @@ { if (type_of(f)==t_fixnum) { return f;} else - { FEerror("Not a fixnum ~s",1,f); return f; + { Icall_error_handler(sLsimple_type_error, + make_simple_string("Not a fixnum ~s"), + 1, + f); return f; } } void Wrong_type_error(char *str,int n,...) { - FEerror("Wrong type error",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Wrong type."), + 0); } object @@ -163,7 +177,9 @@ { object * r = vs_top; object res; - if (p+n != r) { FEerror("bad make struct",0);} + if (p+n != r) { Icall_error_handler(sLsimple_type_error, + make_simple_string("bad make struct"), + 0);} vs_base= p; siLmake_structure(); res = vs_base[0]; @@ -197,7 +213,9 @@ object *b = vs_base,*p=&fcall.values[0]; object res = (n > 0 ? b[0] : sLnil); if (n>=sizeof(fcall.values)/sizeof(*fcall.values)) - FEerror("Too many function call values"); + Icall_error_handler(sLsimple_error, + make_simple_string("Too many function call values"), + 0); while (--n > 0) { *++p= *++b;} return res; @@ -219,7 +237,9 @@ lisp_copy_to_null_terminated(object string, char *buf, int n) { if(type_of(string) != t_string && type_of(string) != t_symbol) - FEerror("Need to give symbol or string",0); + Icall_error_handler(sLsimple_type_error, + make_simple_string("Need to give symbol or string"), + 0); if (string->st.st_fillp +1 > n) { buf= (void *)malloc(string->st.st_fillp +1); }