--- gforth/prim 2010/04/25 18:27:09 1.248 +++ gforth/prim 2011/10/18 13:13:53 1.258 @@ -1,6 +1,6 @@ \ Gforth primitives -\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2009 Free Software Foundation, Inc. +\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2009,2010 Free Software Foundation, Inc. \ This file is part of Gforth. @@ -612,6 +612,24 @@ SET_IP((Xt *)a_target); cell+ THEN >r ; +(try1) ( ... a_oldhandler a_recovery -- R:a_recovery R:a_sp R:f_fp R:c_lp R:a_oldhandler a_newhandler ) gforth paren_try1 +a_sp = sp-1; +f_fp = fp; +c_lp = lp; +a_newhandler = rp-5; + +(throw1) ( ... wball a_handler -- ... wball ) gforth paren_throw1 +rp = a_handler; +lp = (Address)rp[1]; +fp = (Float *)rp[2]; +sp = (Cell *)rp[3]; +#ifndef NO_IP +ip=IP; +#endif +SUPER_END; +VM_JUMP(EXEC1(*(Xt *)rp[4])); + + \+ \ don't make any assumptions where the return stack is!! @@ -1786,6 +1804,8 @@ if (a_addr1==NULL) else a_addr2 = (Cell *)realloc(a_addr1, u); wior = IOR(a_addr2==NULL); /* !! Define a return code */ +if (a_addr2==NULL) + a_addr2 = a_addr1; strerror ( n -- c_addr u ) gforth c_addr = (Char *)strerror(n); @@ -2492,6 +2512,105 @@ c_addr = "libltdl is not configured"; u = strlen(c_addr); #endif +be-w! ( w c_addr -- ) gforth w_store_be +""Store the bottom 16 bits of @i{w} at @i{c_addr} in big endian format."" +c_addr[0] = w >> 8; +c_addr[1] = w; + +be-l! ( w c_addr -- ) gforth l_store_be +""Store the bottom 32 bits of @i{w} at @i{c_addr} in big endian format."" +c_addr[0] = w >> 24; +c_addr[1] = w >> 16; +c_addr[2] = w >> 8; +c_addr[3] = w; + +le-w! ( w c_addr -- ) gforth w_store_le +""Store the bottom 16 bits of @i{w} at @i{c_addr} in big endian format."" +c_addr[1] = w >> 8; +c_addr[0] = w; + +le-l! ( w c_addr -- ) gforth l_store_le +""Store the bottom 32 bits of @i{w} at @i{c_addr} in big endian format."" +c_addr[3] = w >> 24; +c_addr[2] = w >> 16; +c_addr[1] = w >> 8; +c_addr[0] = w; + +be-uw@ ( c_addr -- u ) gforth w_fetch_be +""@i{u} is the zero-extended 16-bit big endian value stored at @i{c_addr}."" +u = (c_addr[0] << 8) | (c_addr[1]); + +be-ul@ ( c_addr -- u ) gforth l_fetch_be +""@i{u} is the zero-extended 32-bit big endian value stored at @i{c_addr}."" +u = (c_addr[0] << 24) | (c_addr[1] << 16) | (c_addr[2] << 8) | (c_addr[3]); + +le-uw@ ( c_addr -- u ) gforth w_fetch_le +""@i{u} is the zero-extended 16-bit little endian value stored at @i{c_addr}."" +u = (c_addr[1] << 8) | (c_addr[0]); + +le-ul@ ( c_addr -- u ) gforth l_fetch_le +""@i{u} is the zero-extended 32-bit little endian value stored at @i{c_addr}."" +u = (c_addr[3] << 24) | (c_addr[2] << 16) | (c_addr[1] << 8) | (c_addr[0]); + +\+64bit + +x! ( w c_addr -- ) gforth x_store +""Store the bottom 64 bits of @i{w} at 64-bit-aligned @i{c_addr}."" +*(UOctabyte *)c_addr = w; + +ux@ ( c_addr -- u ) gforth u_x_fetch +""@i{u} is the zero-extended 64-bit value stored at 64-bit-aligned @i{c_addr}."" +u = *(UOctabyte *)c_addr; + +sx@ ( c_addr -- n ) gforth s_x_fetch +""@i{u} is the sign-extended 64-bit value stored at 64-bit-aligned @i{c_addr}."" +n = *(Octabyte *)c_addr; + +be-x! ( w c_addr -- ) gforth b_e_x_store +""Store the bottom 64 bits of @i{w} at @i{c_addr} in big endian format."" +c_addr[0] = w >> 56; +c_addr[1] = w >> 48; +c_addr[2] = w >> 40; +c_addr[3] = w >> 32; +c_addr[4] = w >> 24; +c_addr[5] = w >> 16; +c_addr[6] = w >> 8; +c_addr[7] = w; + +le-x! ( w c_addr -- ) gforth l_e_x_store +""Store the bottom 64 bits of @i{w} at @i{c_addr} in big endian format."" +c_addr[7] = w >> 56; +c_addr[6] = w >> 48; +c_addr[5] = w >> 40; +c_addr[4] = w >> 32; +c_addr[3] = w >> 24; +c_addr[2] = w >> 16; +c_addr[1] = w >> 8; +c_addr[0] = w; + +be-ux@ ( c_addr -- u ) gforth b_e_u_x_fetch +""@i{u} is the zero-extended 64-bit big endian value stored at @i{c_addr}."" +u = (((Cell)(c_addr[0]) << 56) | + ((Cell)(c_addr[1]) << 48) | + ((Cell)(c_addr[2]) << 40) | + ((Cell)(c_addr[3]) << 32) | + ((Cell)(c_addr[4]) << 24) | + ((Cell)(c_addr[5]) << 16) | + ((Cell)(c_addr[6]) << 8) | + ((Cell)(c_addr[7]))); + +le-ux@ ( c_addr -- u ) gforth l_e_u_x_fetch +""@i{u} is the zero-extended 64-bit little endian value stored at @i{c_addr}."" +u = (((Cell)(c_addr[7]) << 56) | + ((Cell)(c_addr[6]) << 48) | + ((Cell)(c_addr[5]) << 40) | + ((Cell)(c_addr[4]) << 32) | + ((Cell)(c_addr[3]) << 24) | + ((Cell)(c_addr[2]) << 16) | + ((Cell)(c_addr[1]) << 8) | + ((Cell)(c_addr[0]))); + +\+ \+ \g peephole @@ -2559,10 +2678,14 @@ Address body = (Address)PFA(a_cfa); sp = (*f)(sp, &fp_mem, body); fp = fp_mem; -;code-exec ( #a_cfa -- ) gforth-internal semi_code_exec -/* routine for performing ;code-defined words */ +lit-execute ( #a_addr -- ) new lit_execute +/* for ;code and code words; a static superinstruction would be more general, + but VM_JUMP is currently not supported there */ +#ifndef NO_IP +ip=IP; +#endif SUPER_END; -VM_JUMP(EXEC1(a_cfa)); +VM_JUMP(EXEC1((Xt)a_addr)); \g static_super