Menu
▾
▴
[Xsb-commits] CVS: XSB/emu xsb_inst_list.h, 1.20, 1.21 psc_xsb.h, 1.28, 1.29 inst_xsb.h, 1.27, 1.28 function.c, 1.19, 1.20 error_xsb.c, 1.70, 1.71 emuloop.c, 1.171, 1.172
|
From: Terrance S. <ts...@us...> - 2007-10-28 23:32:36
|
Update of /cvsroot/xsb/XSB/emu In directory sc8-pr-cvs10.sourceforge.net:/tmp/cvs-serv27479 Modified Files: xsb_inst_list.h psc_xsb.h inst_xsb.h function.c error_xsb.c emuloop.c Log Message: Added evaluable functions **/2 and sign/1, which were in the core standard. Added an evaluable xor function ></2 which is in the revision. Rewrote arithmetic_abort to give evaluation errors and instantiation errors, making us a little more compliant. We still aren't reporting underflows or overflows, so we do deviate from the standard in this respect. Index: xsb_inst_list.h =================================================================== RCS file: /cvsroot/xsb/XSB/emu/xsb_inst_list.h,v retrieving revision 1.20 retrieving revision 1.21 diff -u -r1.20 -r1.21 --- xsb_inst_list.h 28 Sep 2007 18:20:20 -0000 1.20 +++ xsb_inst_list.h 28 Oct 2007 23:32:35 -0000 1.21 @@ -54,7 +54,7 @@ XSB_INST(0x2c, no_inst, _no_inst, PPP,X,X,X); XSB_INST(0x2d, no_inst, _no_inst, PPP,X,X,X); XSB_INST(0x2e, no_inst, _no_inst, PPP,X,X,X); -XSB_INST(0x2f, no_inst, _no_inst, PPP,X,X,X); +XSB_INST(0x2f, xorreg, _xorreg, P,R,R,X); XSB_INST(0x30, getattv, _getattv, PP, R, X,X); XSB_INST(0x31, putattv, _putattv, PP, R, X,X); @@ -245,7 +245,7 @@ XSB_INST(0xdc, int_test_z, _int_test_z, PP, R, B, L); XSB_INST(0xdd, int_test_nz, _int_test_nz, PP, R, B, L); XSB_INST(0xde, fun_test_ne, _fun_test_ne, PRR, L,X,X); -XSB_INST(0xdf, no_inst, _no_inst, PPP,X,X,X); +XSB_INST(0xdf, powreg, _powreg, P,R,R,X); XSB_INST(0xe0, putdval, _putdval, P, V, R,X); XSB_INST(0xe1, putuval, _putuval, P, V, R,X); Index: psc_xsb.h =================================================================== RCS file: /cvsroot/xsb/XSB/emu/psc_xsb.h,v retrieving revision 1.28 retrieving revision 1.29 diff -u -r1.28 -r1.29 --- psc_xsb.h 22 Oct 2007 16:16:25 -0000 1.28 +++ psc_xsb.h 28 Oct 2007 23:32:35 -0000 1.29 @@ -116,6 +116,7 @@ #define get_opaque(psc) (((psc)->incr & 3) == 2) /* incremental */ // get_xxx_tabled will also succeed if tabling type is not yet known +// set_shared is also used to set_private #define get_subsumptive_tabled(psc) ((psc)->env & T_TABLED_SUB & ~T_TABLED_VAR) #define get_variant_tabled(psc) ((psc)->env & T_TABLED_VAR & ~T_TABLED_SUB) #define get_arity(psc) ((psc)->arity) Index: inst_xsb.h =================================================================== RCS file: /cvsroot/xsb/XSB/emu/inst_xsb.h,v retrieving revision 1.27 retrieving revision 1.28 diff -u -r1.27 -r1.28 --- inst_xsb.h 28 Sep 2007 18:20:13 -0000 1.27 +++ inst_xsb.h 28 Oct 2007 23:32:35 -0000 1.28 @@ -215,6 +215,7 @@ #define unitvar_getlist_uninumcon 0x23 /* combined, same reg, 16-bit int */ #define bldtval_putlist_bldnumcon 0x24 /* combined, same reg, 16-bit int */ #define bldtvar_list_numcon 0x25 /* combined, same reg, 16-bit int */ +#define xorreg 0x2f #define getattv 0x30 #define putattv 0x31 @@ -352,7 +353,7 @@ #define int_test_z 0xdc #define int_test_nz 0xdd #define fun_test_ne 0xde - +#define powreg 0xdf /* Unsafe term instructions */ #define putdval 0xe0 Index: function.c =================================================================== RCS file: /cvsroot/xsb/XSB/emu/function.c,v retrieving revision 1.19 retrieving revision 1.20 diff -u -r1.19 -r1.20 --- function.c 8 Aug 2007 17:50:50 -0000 1.19 +++ function.c 28 Oct 2007 23:32:36 -0000 1.20 @@ -22,10 +22,10 @@ ** */ - #include "xsb_config.h" #include "xsb_debug.h" +#include <stdio.h> #include <math.h> #include "auxlry.h" @@ -60,7 +60,7 @@ #define FUN_truncate 23 #define FUN_round 24 #define FUN_ceiling 25 -#define FUN_max 26 +#define FUN_sign 26 #define FUN_min 27 /* --- returns 1 when succeeds, and returns 0 when there is an error -- */ @@ -227,6 +227,18 @@ bld_oint(regaddr,ivalue); } else return 0; break; + case FUN_sign: + set_fvalue_from_value; + // printf("value %d fvalue %f\n",value,fvalue); + if (fvalue > 0) + bld_int(regaddr,1); + else if (fvalue == 0) + bld_int(regaddr,0); + else if (fvalue < 0) { + bld_int(regaddr,-1); + } + break; + default: return 0; } return 1; Index: error_xsb.c =================================================================== RCS file: /cvsroot/xsb/XSB/emu/error_xsb.c,v retrieving revision 1.70 retrieving revision 1.71 diff -u -r1.70 -r1.71 --- error_xsb.c 7 Oct 2007 17:37:54 -0000 1.70 +++ error_xsb.c 28 Oct 2007 23:32:36 -0000 1.71 @@ -270,6 +270,76 @@ } /*****************/ +/* Not using overflow or underflow yet */ + +#define EVALUATION_DOMAIN_ERROR 0 +#define EVALUATION_INSTANTIATION_ERROR 1 +#define EVALUATION_UNDERFLOW_ERROR 2 +#define EVALUATION_OVERFLOW_ERROR 2 + +void call_conv xsb_basic_evaluation_error(char *message,int type) +{ + prolog_term ball_to_throw; + int isnew; + Cell *tptr; + unsigned long ball_len = 10*sizeof(Cell); +#ifdef MULTI_THREAD + char mtmessage[MAXBUFSIZE]; + int tid = xsb_thread_self(); + th_context *th; + th = find_context(tid); +#endif + + tptr = (Cell *) mem_alloc(ball_len,LEAK_SPACE); + ball_to_throw = makecs(tptr); + bld_functor(tptr, pair_psc(insert("error",3,(Psc)flags[CURRENT_MODULE],&isnew))); + tptr++; + + if (type == EVALUATION_INSTANTIATION_ERROR) { + bld_string(tptr,string_find("instantiation_error",1)); + tptr++; +#ifdef MULTI_THREAD + sprintf(mtmessage,"[th %d] %s",tid,message); + bld_string(tptr,string_find(mtmessage,1)); +#else + bld_string(tptr,string_find(message,1)); +#endif + tptr++; + bld_copy(tptr,build_xsb_backtrace(CTXT)); + } + else if (type == EVALUATION_DOMAIN_ERROR) { + bld_cs(tptr,(Cell) (tptr+3)); + tptr++; +#ifdef MULTI_THREAD + sprintf(mtmessage,"[th %d] %s",tid,message); + bld_string(tptr,string_find(mtmessage,1)); +#else + bld_string(tptr,string_find(message,1)); +#endif + tptr++; + bld_copy(tptr,build_xsb_backtrace(CTXT)); + tptr++; + bld_functor(tptr, pair_psc(insert("evaluation_error",1,(Psc)flags[CURRENT_MODULE],&isnew))); + tptr++; + bld_string(tptr,string_find("undefined",1)); + } + xsb_throw_internal(CTXTc ball_to_throw,ball_len); +} + +DllExport void call_conv xsb_evaluation_error(int type,char *description, ...) +{ + char message[MAXBUFSIZE]; + va_list args; + + va_start(args, description); + strcpy(message, "++Error[XSB]: [Runtime/C] "); + vsprintf(message+strlen(message), description, args); + if (message[strlen(message)-1] == '\n') message[strlen(message)-1] = 0; + va_end(args); + xsb_basic_evaluation_error(message,type); +} + +/*****************/ void call_conv xsb_existence_error(CTXTdeclc char *object,Cell culprit, const char *predicate,int arity, int arg) @@ -742,6 +812,12 @@ /*----------------------------------------------------------------------*/ +/* TLS: changed this to be close to the standard by reporting + instantiation errors and evaluation errors (both reported by + xsb_evaluation_error()). Underflow and overflow errors are still + not caught. +*/ + #define str_op1 (*tsgSBuff1) #define str_op2 (*tsgSBuff2) void arithmetic_abort(CTXTdeclc Cell op1, char *OP, Cell op2) @@ -751,17 +827,22 @@ print_pterm(CTXTc op1, TRUE, &str_op1); print_pterm(CTXTc op2, TRUE, &str_op2); if (isref(op1) || isref(op2)) { - xsb_abort("Uninstantiated argument of evaluable function %s/2\n%s %s %s %s%s", - OP, " Goal:", - (isref(op1)? "_Var": str_op1.string), - OP, - (isref(op2)? "_Var": str_op2.string), - ", probably as 2nd arg of is/2"); + xsb_evaluation_error(EVALUATION_INSTANTIATION_ERROR, + "Uninstantiated argument of evaluable function %s/2\n%s %s %s %s%s", + OP, " Goal:", + (isref(op1)? "_Var": str_op1.string), + OP, + (isref(op2)? "_Var": str_op2.string), + ", probably as 2nd arg of is/2"); } else { - xsb_abort("Wrong domain in evaluable function %s/2\n%s %s %s %s found", - OP, " Arithmetic expression expected, but", - str_op1.string, OP, str_op2.string); + // xsb_abort("Wrong domain in evaluable function %s/2\n%s %s %s %s found", + // OP, " Arithmetic expression expected, but", + // str_op1.string, OP, str_op2.string); + xsb_evaluation_error(EVALUATION_DOMAIN_ERROR, + "Wrong domain in evaluable function %s/2\n%s %s %s %s found", + OP, " Arithmetic expression expected, but", + str_op1.string, OP, str_op2.string); } } #undef str_op1 @@ -1008,6 +1089,7 @@ int clean_up_block(CTXTdeclc int bregBefore) { if (bregBefore == (int) ((pb)tcpstack.high - (pb)breg)) { + // printf("setting breg %x to prevbreg %x\n",breg,cp_prevbreg(breg)); breg = (CPtr)cp_prevbreg(breg); } return(TRUE); Index: emuloop.c =================================================================== RCS file: /cvsroot/xsb/XSB/emu/emuloop.c,v retrieving revision 1.171 retrieving revision 1.172 diff -u -r1.171 -r1.172 --- emuloop.c 22 Oct 2007 16:16:24 -0000 1.171 +++ emuloop.c 28 Oct 2007 23:32:36 -0000 1.172 @@ -30,6 +30,7 @@ #include <stdlib.h> #include <signal.h> #include <string.h> +#include <math.h> #ifdef FOREIGN #ifndef SOLARIS @@ -550,6 +551,40 @@ nunify_with_list_sym(op1); XSB_End_Instr() + /* TLS: so much work for such a little function! */ + XSB_Start_Instr(xorreg,_xorreg) /* PRR */ + Def3ops + Op1(Register(get_xrx)); + Op3(get_xxr); + ADVANCE_PC(size_xxx); + op2 = *(op3); + XSB_Deref(op1); + XSB_Deref(op2); + if (isinteger(op1)) { + if (isinteger(op2)) { + Integer temp = (int_val(op2)) ^ (int_val(op1)); + bld_oint(op3, temp); + } + else if (isboxedinteger(op2)) { + Integer temp = (boxedint_val(op2)) ^ (int_val(op1)); + bld_oint(op3, temp); + } + else {arithmetic_abort(CTXTc op2, "'><'", op1);} + } + else if (isboxedinteger(op1)) { + if (isinteger(op2)) { + Integer temp = (int_val(op2)) ^ (boxedint_val(op1)); + bld_oint(op3, temp); + } + else if (isboxedinteger(op2)) { + Integer temp = (boxedint_val(op2)) ^ (boxedint_val(op1)); + bld_oint(op3, temp); + } + else {arithmetic_abort(CTXTc op2, "'><'", op1);} + } + else {arithmetic_abort(CTXTc op2, "'><'", op1);} + XSB_End_Instr() + XSB_Start_Instr(getattv,_getattv) /* PPR */ Def1op Op1(Register(get_xxr)); @@ -1693,6 +1728,40 @@ XSB_End_Instr() /* TLS: so much work for such a little function! */ + XSB_Start_Instr(powreg,_powreg) /* PRR */ + Def3ops + Op1(Register(get_xrx)); + Op3(get_xxr); + ADVANCE_PC(size_xxx); + op2 = *(op3); + XSB_Deref(op1); + XSB_Deref(op2); + if (isinteger(op1)) { + if (isinteger(op2)) { + Integer temp = pow(int_val(op2),int_val(op1)); + bld_oint(op3, temp); + } + else if (isboxedinteger(op2)) { + Integer temp = pow(boxedint_val(op2),int_val(op1)); + bld_oint(op3, temp); + } + else {arithmetic_abort(CTXTc op2, "'**'", op1);} + } + else if (isboxedinteger(op1)) { + if (isinteger(op2)) { + Integer temp = pow(int_val(op2),boxedint_val(op1)); + bld_oint(op3, temp); + } + else if (isboxedinteger(op2)) { + Integer temp = pow(boxedint_val(op2),boxedint_val(op1)); + bld_oint(op3, temp); + } + else {arithmetic_abort(CTXTc op2, "'**'", op1);} + } + else {arithmetic_abort(CTXTc op2, "'**'", op1);} + XSB_End_Instr() + + /* TLS: so much work for such a little function! */ XSB_Start_Instr(minreg,_minreg) /* PRR */ Def3ops Op1(Register(get_xrx)); |