--- gforth/prim 2010/04/05 22:17:56 1.246 +++ gforth/prim 2010/05/17 09:01:11 1.250 @@ -229,18 +229,24 @@ fprintf(stderr, "dodoes to %x, push %x\n SET_IP(DOES_CODE1(CFA)); #endif /* !defined(NO_IP) */ -(does-handler) ( -- ) gforth-internal paren_does_handler -""just a slot to have an encoding for the DOESJUMP, -which is no longer used anyway (!! eliminate this)"" - -(doabicode) ( s:... f:... -- s:... f:...) gforth-internal paren_doabicode -""run-time routine for ABI-CODE definitions"" -struct abi_code_ret_t { - Cell *sp; - double * fp; -} ret = ((struct abi_code_ret_t(*)(Cell *, double *))(PFA(CFA)))(sp, fp); -sp = ret.sp; -fp = ret.fp; +(doabicode) ( ... -- ...) gforth-internal paren_doabicode +""run-time routine for @code{ABI-code} definitions"" +abifunc *f = (abifunc *)PFA(CFA); +Float *fp_mem = fp; +sp = (*f)(sp, &fp_mem); +fp = fp_mem; +#ifdef NO_IP +INST_TAIL; +goto *next_code; +#endif /* defined(NO_IP) */ + +(do;abicode) ( ... -- ... ) gforth-internal paren_do_semicolon_abi_code +""run-time routine for @code{;abi-code}-defined words"" +Float *fp_mem = fp; +Address body = (Address)PFA(CFA); +semiabifunc *f = (semiabifunc *)DOES_CODE1(CFA); +sp = (*f)(sp, &fp_mem, body); +fp = fp_mem; #ifdef NO_IP INST_TAIL; goto *next_code; @@ -638,14 +644,6 @@ k ( R:w R:w1 R:w2 R:w3 R:w4 -- w R:w R:w \ digit is high-level: 0/0% -abi-call ( #a_callee s:... f:... -- s:... f:... ) gforth abi_call -struct abi_code_ret_t { - Cell *sp; - double * fp; -} ret = ((struct abi_code_ret_t(*)(Cell *, double *))(a_callee))(sp, fp); -sp = ret.sp; -fp = ret.fp; - \g strings move ( c_from c_to ucount -- ) core @@ -2494,6 +2492,54 @@ c_addr = "libltdl is not configured"; u = strlen(c_addr); #endif +w!be ( w c_addr -- ) gforth w_store_be +""Store the bottom 16 bits of @i{w} at @i{c_addr} in big endian format."" +*(Wyde*)(c_addr) = htobe16(w); + +l!be ( w c_addr -- ) gforth l_store_be +""Store the bottom 32 bits of @i{w} at @i{c_addr} in big endian format."" +*(Tetrabyte*)(c_addr) = htobe32(w); + +x!be ( w c_addr -- ) gforth x_store_be +""Store the bottom 64 bits of @i{w} at @i{c_addr} in big endian format."" +*(Octabyte*)(c_addr) = htobe64(w); + +w!le ( w c_addr -- ) gforth w_store_le +""Store the bottom 16 bits of @i{w} at @i{c_addr} in big endian format."" +*(Wyde*)(c_addr) = htole16(w); + +l!le ( w c_addr -- ) gforth l_store_le +""Store the bottom 32 bits of @i{w} at @i{c_addr} in big endian format."" +*(Tetrabyte*)(c_addr) = htole32(w); + +x!le ( w c_addr -- ) gforth x_store_le +""Store the bottom 64 bits of @i{w} at @i{c_addr} in big endian format."" +*(Octabyte*)(c_addr) = htole64(w); + +w@be ( c_addr -- u ) gforth w_fetch_be +""@i{u} is the zero-extended 16-bit big endian value stored at @i{c_addr}."" +u = be16toh(*(UWyde*)(c_addr)); + +l@be ( c_addr -- u ) gforth l_fetch_be +""@i{u} is the zero-extended 32-bit big endian value stored at @i{c_addr}."" +u = be32toh(*(UTetrabyte*)(c_addr)); + +x@be ( c_addr -- u ) gforth x_fetch_be +""@i{u} is the zero-extended 64-bit big endian value stored at @i{c_addr}."" +u = be64toh(*(UOctabyte*)(c_addr)); + +w@le ( c_addr -- u ) gforth w_fetch_le +""@i{u} is the zero-extended 16-bit little endian value stored at @i{c_addr}."" +u = le16toh(*(UWyde*)(c_addr)); + +l@le ( c_addr -- u ) gforth l_fetch_le +""@i{u} is the zero-extended 32-bit little endian value stored at @i{c_addr}."" +u = le32toh(*(UTetrabyte*)(c_addr)); + +x@le ( c_addr -- u ) gforth x_fetch_le +""@i{u} is the zero-extended 64-bit little endian value stored at @i{c_addr}."" +u = le64toh(*(UOctabyte*)(c_addr)); + \+ \g peephole @@ -2541,6 +2587,36 @@ a_addr = groups; \+ +\g primitive_centric + +\ primitives for primitive-centric code +\ another one is does-exec + +abi-call ( #a_callee ... -- ... ) gforth-internal abi_call +/* primitive for compiled ABI-CODE words */ +abifunc *f = (abifunc *)a_callee; +Float *fp_mem = fp; +sp = (*f)(sp, &fp_mem); +fp = fp_mem; + +;abi-code-exec ( #a_cfa ... -- ... ) gforth-internal semi_abi_code_exec +/* primitive for performing ;ABI-CODE words */ +Float *fp_mem = fp; +semiabifunc *f = (semiabifunc *)DOES_CODE1(a_cfa); +Address body = (Address)PFA(a_cfa); +sp = (*f)(sp, &fp_mem, body); +fp = fp_mem; + +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((Xt)a_addr)); + + \g static_super ifdef(`STACK_CACHE_FILE',