version 1.243, 2009/06/29 20:21:28
|
version 1.254, 2010/08/21 19:08:46
|
Line 1
|
Line 1
|
\ Gforth primitives |
\ Gforth primitives |
|
|
\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008 Free Software Foundation, Inc. |
\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2009 Free Software Foundation, Inc. |
|
|
\ This file is part of Gforth. |
\ This file is part of Gforth. |
|
|
Line 229 fprintf(stderr, "dodoes to %x, push %x\n
|
Line 229 fprintf(stderr, "dodoes to %x, push %x\n
|
SET_IP(DOES_CODE1(CFA)); |
SET_IP(DOES_CODE1(CFA)); |
#endif /* !defined(NO_IP) */ |
#endif /* !defined(NO_IP) */ |
|
|
(does-handler) ( -- ) gforth-internal paren_does_handler |
(doabicode) ( ... -- ...) gforth-internal paren_doabicode |
""just a slot to have an encoding for the DOESJUMP, |
""run-time routine for @code{ABI-code} definitions"" |
which is no longer used anyway (!! eliminate this)"" |
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; |
|
#endif /* defined(NO_IP) */ |
|
|
\F [endif] |
\F [endif] |
|
|
Line 2465 lib-error ( -- c_addr u ) gforth
|
Line 2484 lib-error ( -- c_addr u ) gforth
|
#ifdef HAVE_LIBLTDL |
#ifdef HAVE_LIBLTDL |
c_addr = (Char *)lt_dlerror(); |
c_addr = (Char *)lt_dlerror(); |
u = (c_addr == NULL) ? 0 : strlen((char *)c_addr); |
u = (c_addr == NULL) ? 0 : strlen((char *)c_addr); |
|
#elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) |
|
c_addr = dlerror(); |
|
u = strlen(c_addr); |
#else |
#else |
c_addr = "libltdl is not configured"; |
c_addr = "libltdl is not configured"; |
u = strlen(c_addr); |
u = strlen(c_addr); |
#endif |
#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 |
\g peephole |
|
|
Line 2517 a_addr = groups;
|
Line 2638 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 |
\g static_super |
|
|
ifdef(`STACK_CACHE_FILE', |
ifdef(`STACK_CACHE_FILE', |