| \ Gforth primitives |
\ Gforth primitives |
| |
|
| \ Copyright (C) 1995,1996 Free Software Foundation, Inc. |
\ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2009,2010,2011 Free Software Foundation, Inc. |
| |
|
| \ This file is part of Gforth. |
\ This file is part of Gforth. |
| |
|
| \ Gforth is free software; you can redistribute it and/or |
\ Gforth is free software; you can redistribute it and/or |
| \ modify it under the terms of the GNU General Public License |
\ modify it under the terms of the GNU General Public License |
| \ as published by the Free Software Foundation; either version 2 |
\ as published by the Free Software Foundation, either version 3 |
| \ of the License, or (at your option) any later version. |
\ of the License, or (at your option) any later version. |
| |
|
| \ This program is distributed in the hope that it will be useful, |
\ This program is distributed in the hope that it will be useful, |
| \ GNU General Public License for more details. |
\ GNU General Public License for more details. |
| |
|
| \ You should have received a copy of the GNU General Public License |
\ You should have received a copy of the GNU General Public License |
| \ along with this program; if not, write to the Free Software |
\ along with this program. If not, see http://www.gnu.org/licenses/. |
| \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA. |
|
| |
|
| |
|
| \ WARNING: This file is processed by m4. Make sure your identifiers |
\ WARNING: This file is processed by m4. Make sure your identifiers |
| \ |
\ |
| \ This file contains primitive specifications in the following format: |
\ This file contains primitive specifications in the following format: |
| \ |
\ |
| \ forth name stack effect category [pronunciation] |
\ forth name ( stack effect ) category [pronunciation] |
| \ [""glossary entry""] |
\ [""glossary entry""] |
| \ C code |
\ C code |
| \ [: |
\ [: |
| \ Forth code] |
\ Forth code] |
| \ |
\ |
| \ prims2x is pedantic about tabs vs. blanks. The fields of the first |
\ Note: Fields in brackets are optional. Word specifications have to |
| \ line of a primitive are separated by tabs, the stack items in a |
\ be separated by at least one empty line |
| \ stack effect by blanks. |
|
| \ |
\ |
| \ Both pronounciation and stack items (in the stack effect) must |
\ Both pronounciation and stack items (in the stack effect) must |
| \ conform to the C name syntax or the C compiler will complain. |
\ conform to the C identifier syntax or the C compiler will complain. |
| \ |
\ If you don't have a pronounciation field, the Forth name is used, |
| |
\ and has to conform to the C identifier syntax. |
| \ |
\ |
| \ These specifications are automatically translated into C-code for the |
\ These specifications are automatically translated into C-code for the |
| \ interpreter and into some other files. I hope that your C compiler has |
\ interpreter and into some other files. I hope that your C compiler has |
| \ stack. Use different names on both sides of the '--', if you change a |
\ stack. Use different names on both sides of the '--', if you change a |
| \ value (some stores to the stack are optimized away). |
\ value (some stores to the stack are optimized away). |
| \ |
\ |
| |
\ For superinstructions the syntax is: |
| |
\ |
| |
\ forth-name [/ c-name] = forth-name forth-name ... |
| \ |
\ |
| \ |
\ |
| \ The stack variables have the following types: |
\ The stack variables have the following types: |
| \ df_.* DFloat * |
\ df_.* DFloat * |
| \ sf_.* SFloat * |
\ sf_.* SFloat * |
| \ xt.* XT |
\ xt.* XT |
| \ wid.* WID |
|
| \ f83name.* F83Name * |
\ f83name.* F83Name * |
| |
|
| |
\E stack data-stack sp Cell |
| |
\E stack fp-stack fp Float |
| |
\E stack return-stack rp Cell |
| |
\E |
| |
\E get-current prefixes set-current |
| |
\E |
| |
\E s" Bool" single data-stack type-prefix f |
| |
\E s" Char" single data-stack type-prefix c |
| |
\E s" Cell" single data-stack type-prefix n |
| |
\E s" Cell" single data-stack type-prefix w |
| |
\E s" UCell" single data-stack type-prefix u |
| |
\E s" DCell" double data-stack type-prefix d |
| |
\E s" UDCell" double data-stack type-prefix ud |
| |
\E s" Float" single fp-stack type-prefix r |
| |
\E s" Cell *" single data-stack type-prefix a_ |
| |
\E s" Char *" single data-stack type-prefix c_ |
| |
\E s" Float *" single data-stack type-prefix f_ |
| |
\E s" DFloat *" single data-stack type-prefix df_ |
| |
\E s" SFloat *" single data-stack type-prefix sf_ |
| |
\E s" Xt" single data-stack type-prefix xt |
| |
\E s" struct F83Name *" single data-stack type-prefix f83name |
| |
\E s" struct Longname *" single data-stack type-prefix longname |
| |
\E |
| |
\E data-stack stack-prefix S: |
| |
\E fp-stack stack-prefix F: |
| |
\E return-stack stack-prefix R: |
| |
\E inst-stream stack-prefix # |
| |
\E |
| |
\E set-current |
| |
\E store-optimization on |
| |
\E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump |
| |
\E |
| |
\E `include-skipped-insts' on \ static superinsts include cells for components |
| |
\E \ useful for dynamic programming and |
| |
\E \ superinsts across entry points |
| |
|
| \ |
\ |
| \ |
\ |
| \ |
\ |
| \ throw execute, cfa and NEXT1 out? |
\ throw execute, cfa and NEXT1 out? |
| \ macroize *ip, ip++, *ip++ (pipelining)? |
\ macroize *ip, ip++, *ip++ (pipelining)? |
| |
|
| |
\ Stack caching setup |
| |
|
| |
ifdef(`STACK_CACHE_FILE', `include(STACK_CACHE_FILE)', `include(cache0.vmg)') |
| |
|
| \ these m4 macros would collide with identifiers |
\ these m4 macros would collide with identifiers |
| undefine(`index') |
undefine(`index') |
| undefine(`shift') |
undefine(`shift') |
| |
undefine(`symbols') |
| |
|
| noop -- gforth |
\F 0 [if] |
| ; |
|
| |
\ run-time routines for non-primitives. They are defined as |
| |
\ primitives, because that simplifies things. |
| |
|
| |
(docol) ( -- R:a_retaddr ) gforth-internal paren_docol |
| |
""run-time routine for colon definitions"" |
| |
#ifdef NO_IP |
| |
a_retaddr = next_code; |
| |
INST_TAIL; |
| |
goto **(Label *)PFA(CFA); |
| |
#else /* !defined(NO_IP) */ |
| |
a_retaddr = (Cell *)IP; |
| |
SET_IP((Xt *)PFA(CFA)); |
| |
#endif /* !defined(NO_IP) */ |
| |
|
| |
(docon) ( -- w ) gforth-internal paren_docon |
| |
""run-time routine for constants"" |
| |
w = *(Cell *)PFA(CFA); |
| |
#ifdef NO_IP |
| |
INST_TAIL; |
| |
goto *next_code; |
| |
#endif /* defined(NO_IP) */ |
| |
|
| |
(dovar) ( -- a_body ) gforth-internal paren_dovar |
| |
""run-time routine for variables and CREATEd words"" |
| |
a_body = PFA(CFA); |
| |
#ifdef NO_IP |
| |
INST_TAIL; |
| |
goto *next_code; |
| |
#endif /* defined(NO_IP) */ |
| |
|
| |
(douser) ( -- a_user ) gforth-internal paren_douser |
| |
""run-time routine for constants"" |
| |
a_user = (Cell *)(up+*(Cell *)PFA(CFA)); |
| |
#ifdef NO_IP |
| |
INST_TAIL; |
| |
goto *next_code; |
| |
#endif /* defined(NO_IP) */ |
| |
|
| |
(dodefer) ( -- ) gforth-internal paren_dodefer |
| |
""run-time routine for deferred words"" |
| |
#ifndef NO_IP |
| |
ip=IP; /* undo any ip updating that may have been performed by NEXT_P0 */ |
| |
#endif /* !defined(NO_IP) */ |
| |
SUPER_END; /* !! probably unnecessary and may lead to measurement errors */ |
| |
VM_JUMP(EXEC1(*(Xt *)PFA(CFA))); |
| |
|
| |
(dofield) ( n1 -- n2 ) gforth-internal paren_field |
| |
""run-time routine for fields"" |
| |
n2 = n1 + *(Cell *)PFA(CFA); |
| |
#ifdef NO_IP |
| |
INST_TAIL; |
| |
goto *next_code; |
| |
#endif /* defined(NO_IP) */ |
| |
|
| |
(dovalue) ( -- w ) gforth-internal paren_doval |
| |
""run-time routine for constants"" |
| |
w = *(Cell *)PFA(CFA); |
| |
#ifdef NO_IP |
| |
INST_TAIL; |
| |
goto *next_code; |
| |
#endif /* defined(NO_IP) */ |
| |
|
| |
(dodoes) ( -- a_body R:a_retaddr ) gforth-internal paren_dodoes |
| |
""run-time routine for @code{does>}-defined words"" |
| |
#ifdef NO_IP |
| |
a_retaddr = next_code; |
| |
a_body = PFA(CFA); |
| |
INST_TAIL; |
| |
#ifdef DEBUG |
| |
fprintf(stderr, "dodoes to %x, push %x\n", a_retaddr, a_body); |
| |
#endif |
| |
goto **(Label *)DOES_CODE1(CFA); |
| |
#else /* !defined(NO_IP) */ |
| |
a_retaddr = (Cell *)IP; |
| |
a_body = PFA(CFA); |
| |
#ifdef DEBUG |
| |
fprintf(stderr, "dodoes to %x, push %x\n", a_retaddr, a_body); |
| |
#endif |
| |
SET_IP(DOES_CODE1(CFA)); |
| |
#endif /* !defined(NO_IP) */ |
| |
|
| |
(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; |
| |
#endif /* defined(NO_IP) */ |
| |
|
| |
\F [endif] |
| |
|
| |
\g control |
| |
|
| |
noop ( -- ) gforth |
| : |
: |
| ; |
; |
| |
|
| lit -- w gforth |
call ( #a_callee -- R:a_retaddr ) new |
| w = (Cell)NEXT_INST; |
""Call callee (a variant of docol with inline argument)."" |
| INC_IP(1); |
#ifdef NO_IP |
| : |
assert(0); |
| r> dup @ swap cell+ >r ; |
INST_TAIL; |
| |
JUMP(a_callee); |
| |
#else |
| |
#ifdef DEBUG |
| |
{ |
| |
CFA_TO_NAME((((Cell *)a_callee)-2)); |
| |
fprintf(stderr,"%08lx: call %08lx %.*s\n",(Cell)ip,(Cell)a_callee, |
| |
len,name); |
| |
} |
| |
#endif |
| |
a_retaddr = (Cell *)IP; |
| |
SET_IP((Xt *)a_callee); |
| |
#endif |
| |
|
| execute xt -- core |
execute ( xt -- ) core |
| |
""Perform the semantics represented by the execution token, @i{xt}."" |
| |
#ifdef DEBUG |
| |
fprintf(stderr, "execute %08x\n", xt); |
| |
#endif |
| |
#ifndef NO_IP |
| ip=IP; |
ip=IP; |
| IF_TOS(TOS = sp[0]); |
#endif |
| EXEC(xt); |
SUPER_END; |
| |
VM_JUMP(EXEC1(xt)); |
| |
|
| perform a_addr -- gforth |
perform ( a_addr -- ) gforth |
| ""equivalent to @code{@ execute}"" |
""@code{@@ execute}."" |
| /* and pfe */ |
/* and pfe */ |
| |
#ifndef NO_IP |
| ip=IP; |
ip=IP; |
| IF_TOS(TOS = sp[0]); |
#endif |
| EXEC(*(Xt *)a_addr); |
SUPER_END; |
| |
VM_JUMP(EXEC1(*(Xt *)a_addr)); |
| : |
: |
| @ execute ; |
@ execute ; |
| |
|
| \+has-locals [IF] |
;s ( R:w -- ) gforth semis |
| |
""The primitive compiled by @code{EXIT}."" |
| |
#ifdef NO_IP |
| |
INST_TAIL; |
| |
goto *(void *)w; |
| |
#else |
| |
SET_IP((Xt *)w); |
| |
#endif |
| |
|
| |
unloop ( R:w1 R:w2 -- ) core |
| |
/* !! alias for 2rdrop */ |
| |
: |
| |
r> rdrop rdrop >r ; |
| |
|
| |
lit-perform ( #a_addr -- ) new lit_perform |
| |
#ifndef NO_IP |
| |
ip=IP; |
| |
#endif |
| |
SUPER_END; |
| |
VM_JUMP(EXEC1(*(Xt *)a_addr)); |
| |
|
| |
does-exec ( #a_cfa -- R:nest a_pfa ) new does_exec |
| |
#ifdef NO_IP |
| |
/* compiled to LIT CALL by compile_prim */ |
| |
assert(0); |
| |
#else |
| |
a_pfa = PFA(a_cfa); |
| |
nest = (Cell)IP; |
| |
#ifdef DEBUG |
| |
{ |
| |
CFA_TO_NAME(a_cfa); |
| |
fprintf(stderr,"%08lx: does %08lx %.*s\n", |
| |
(Cell)ip,(Cell)a_cfa,len,name); |
| |
} |
| |
#endif |
| |
SET_IP(DOES_CODE1(a_cfa)); |
| |
#endif |
| |
|
| |
\+glocals |
| |
|
| branch-lp+!# -- gforth branch_lp_plus_store_number |
branch-lp+!# ( #a_target #nlocals -- ) gforth branch_lp_plus_store_number |
| /* this will probably not be used */ |
/* this will probably not be used */ |
| branch_adjust_lp: |
lp += nlocals; |
| lp += (Cell)(IP[1]); |
#ifdef NO_IP |
| goto branch; |
INST_TAIL; |
| |
JUMP(a_target); |
| |
#else |
| |
SET_IP((Xt *)a_target); |
| |
#endif |
| |
|
| \+[THEN] |
\+ |
| |
|
| branch -- gforth |
branch ( #a_target -- ) gforth |
| branch: |
#ifdef NO_IP |
| ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST); |
INST_TAIL; |
| NEXT_P0; |
JUMP(a_target); |
| |
#else |
| |
SET_IP((Xt *)a_target); |
| |
#endif |
| : |
: |
| r> dup @ + >r ; |
r> @ >r ; |
| |
|
| \ condbranch(forthname,restline,code,forthcode) |
\ condbranch(forthname,stackeffect,restline,code1,code2,forthcode) |
| \ this is non-syntactical: code must open a brace that is closed by the macro |
\ this is non-syntactical: code must open a brace that is closed by the macro |
| define(condbranch, |
define(condbranch, |
| $1 $2 |
$1 ( `#'a_target $2 ) $3 |
| $3 ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST); |
$4 #ifdef NO_IP |
| NEXT_P0; |
INST_TAIL; |
| NEXT; |
#endif |
| |
$5 #ifdef NO_IP |
| |
JUMP(a_target); |
| |
#else |
| |
SET_IP((Xt *)a_target); |
| |
ifelse(condbranch_opt,`1',`INST_TAIL; NEXT_P2;',`/* condbranch_opt=0 */') |
| |
#endif |
| } |
} |
| else |
ifelse(condbranch_opt,`1',`SUPER_CONTINUE;',`/* condbranch_opt=0 */') |
| INC_IP(1); |
$6 |
| $4 |
|
| |
|
| \+has-locals [IF] |
\+glocals |
| |
|
| $1-lp+!# $2_lp_plus_store_number |
$1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number |
| $3 goto branch_adjust_lp; |
$4 #ifdef NO_IP |
| |
INST_TAIL; |
| |
#endif |
| |
$5 lp += nlocals; |
| |
#ifdef NO_IP |
| |
JUMP(a_target); |
| |
#else |
| |
SET_IP((Xt *)a_target); |
| |
ifelse(condbranch_opt,`1',`INST_TAIL; NEXT_P2;',`/* condbranch_opt=0 */') |
| |
#endif |
| } |
} |
| else |
ifelse(condbranch_opt,`1',`SUPER_CONTINUE;',`/* condbranch_opt=0 */') |
| INC_IP(2); |
|
| |
|
| \+[THEN] |
\+ |
| ) |
) |
| |
|
| condbranch(?branch,f -- f83 question_branch, |
condbranch(?branch,f --,f83 question_branch, |
| if (f==0) { |
,if (f==0) { |
| IF_TOS(TOS = sp[0]); |
,: |
| ,) |
0= dup 0= \ !f f |
| |
r> tuck cell+ \ !f branchoffset f IP+ |
| |
and -rot @ and or \ f&IP+|!f&branch |
| |
>r ;) |
| |
|
| \ we don't need an lp_plus_store version of the ?dup-stuff, because it |
\ we don't need an lp_plus_store version of the ?dup-stuff, because it |
| \ is only used in if's (yet) |
\ is only used in if's (yet) |
| |
|
| \+has-xconds [IF] |
\+xconds |
| |
|
| ?dup-?branch f -- f new question_dupe_question_branch |
?dup-?branch ( #a_target f -- S:... ) new question_dupe_question_branch |
| ""The run-time procedure compiled by @code{?DUP-IF}."" |
""The run-time procedure compiled by @code{?DUP-IF}."" |
| if (f==0) { |
if (f==0) { |
| sp++; |
#ifdef NO_IP |
| IF_TOS(TOS = sp[0]); |
INST_TAIL; |
| ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST); |
JUMP(a_target); |
| NEXT_P0; |
#else |
| NEXT; |
SET_IP((Xt *)a_target); |
| |
#endif |
| |
} else { |
| |
sp--; |
| |
sp[0]=f; |
| } |
} |
| else |
|
| INC_IP(1); |
|
| |
|
| ?dup-0=-?branch f -- new question_dupe_zero_equals_question_branch |
?dup-0=-?branch ( #a_target f -- S:... ) new question_dupe_zero_equals_question_branch |
| ""The run-time procedure compiled by @code{?DUP-0=-IF}."" |
""The run-time procedure compiled by @code{?DUP-0=-IF}."" |
| /* the approach taken here of declaring the word as having the stack |
|
| effect ( f -- ) and correcting for it in the branch-taken case costs a |
|
| few cycles in that case, but is easy to convert to a CONDBRANCH |
|
| invocation */ |
|
| if (f!=0) { |
if (f!=0) { |
| sp--; |
sp--; |
| ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST); |
sp[0]=f; |
| NEXT_P0; |
#ifdef NO_IP |
| NEXT; |
JUMP(a_target); |
| |
#else |
| |
SET_IP((Xt *)a_target); |
| |
#endif |
| } |
} |
| else |
|
| INC_IP(1); |
|
| |
|
| \+[THEN] |
\+ |
| |
\fhas? skiploopprims 0= [IF] |
| |
|
| condbranch((next),-- cmFORTH paren_next, |
condbranch((next),R:n1 -- R:n2,cmFORTH paren_next, |
| if ((*rp)--) { |
n2=n1-1; |
| |
,if (n1) { |
| ,: |
,: |
| r> r> dup 1- >r |
r> r> dup 1- >r |
| IF dup @ + >r ELSE cell+ >r THEN ;) |
IF @ >r ELSE cell+ >r THEN ;) |
| |
|
| condbranch((loop),-- gforth paren_loop, |
condbranch((loop),R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_loop, |
| Cell index = *rp+1; |
n2=n1+1; |
| Cell limit = rp[1]; |
,if (n2 != nlimit) { |
| if (index != limit) { |
|
| *rp = index; |
|
| ,: |
,: |
| r> r> 1+ r> 2dup = |
r> r> 1+ r> 2dup = |
| IF >r 1- >r cell+ >r |
IF >r 1- >r cell+ >r |
| ELSE >r >r dup @ + >r THEN ;) |
ELSE >r >r @ >r THEN ;) |
| |
|
| condbranch((+loop),n -- gforth paren_plus_loop, |
condbranch((+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_plus_loop, |
| /* !! check this thoroughly */ |
/* !! check this thoroughly */ |
| Cell index = *rp; |
|
| /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */ |
/* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */ |
| /* dependent upon two's complement arithmetic */ |
/* dependent upon two's complement arithmetic */ |
| Cell olddiff = index-rp[1]; |
Cell olddiff = n1-nlimit; |
| if ((olddiff^(olddiff+n))>=0 /* the limit is not crossed */ |
n2=n1+n; |
| || (olddiff^n)>=0 /* it is a wrap-around effect */) { |
,if (((olddiff^(olddiff+n)) /* the limit is not crossed */ |
| #ifdef i386 |
&(olddiff^n)) /* OR it is a wrap-around effect */ |
| *rp += n; |
>=0) { /* & is used to avoid having two branches for gforth-native */ |
| #else |
|
| *rp = index + n; |
|
| #endif |
|
| IF_TOS(TOS = sp[0]); |
|
| ,: |
,: |
| r> swap |
r> swap |
| r> r> 2dup - >r |
r> r> 2dup - >r |
| 2 pick r@ + r@ xor 0< 0= |
2 pick r@ + r@ xor 0< 0= |
| 3 pick r> xor 0< 0= or |
3 pick r> xor 0< 0= or |
| IF >r + >r dup @ + >r |
IF >r + >r @ >r |
| ELSE >r >r drop cell+ >r THEN ;) |
ELSE >r >r drop cell+ >r THEN ;) |
| |
|
| \+has-xconds [IF] |
\+xconds |
| |
|
| condbranch((-loop),u -- gforth paren_minus_loop, |
condbranch((-loop),u R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_minus_loop, |
| /* !! check this thoroughly */ |
UCell olddiff = n1-nlimit; |
| Cell index = *rp; |
n2=n1-u; |
| UCell olddiff = index-rp[1]; |
,if (olddiff>u) { |
| if (olddiff>u) { |
|
| #ifdef i386 |
|
| *rp -= u; |
|
| #else |
|
| *rp = index - u; |
|
| #endif |
|
| IF_TOS(TOS = sp[0]); |
|
| ,) |
,) |
| |
|
| condbranch((s+loop),n -- gforth paren_symmetric_plus_loop, |
condbranch((s+loop),n R:nlimit R:n1 -- R:nlimit R:n2,gforth paren_symmetric_plus_loop, |
| ""The run-time procedure compiled by S+LOOP. It loops until the index |
""The run-time procedure compiled by S+LOOP. It loops until the index |
| crosses the boundary between limit and limit-sign(n). I.e. a symmetric |
crosses the boundary between limit and limit-sign(n). I.e. a symmetric |
| version of (+LOOP)."" |
version of (+LOOP)."" |
| /* !! check this thoroughly */ |
/* !! check this thoroughly */ |
| Cell index = *rp; |
Cell diff = n1-nlimit; |
| Cell diff = index-rp[1]; |
|
| Cell newdiff = diff+n; |
Cell newdiff = diff+n; |
| if (n<0) { |
if (n<0) { |
| diff = -diff; |
diff = -diff; |
| newdiff = -newdiff; |
newdiff = -newdiff; |
| } |
} |
| if (diff>=0 || newdiff<0) { |
n2=n1+n; |
| #ifdef i386 |
,if (((~diff)|newdiff)<0) { /* use | to avoid two branches for gforth-native */ |
| *rp += n; |
|
| #else |
|
| *rp = index + n; |
|
| #endif |
|
| IF_TOS(TOS = sp[0]); |
|
| ,) |
,) |
| |
|
| \+[THEN] |
\+ |
| |
|
| unloop -- core |
|
| rp += 2; |
|
| : |
|
| r> rdrop rdrop >r ; |
|
| |
|
| (for) ncount -- cmFORTH paren_for |
(for) ( ncount -- R:nlimit R:ncount ) cmFORTH paren_for |
| /* or (for) = >r -- collides with unloop! */ |
/* or (for) = >r -- collides with unloop! */ |
| *--rp = 0; |
nlimit=0; |
| *--rp = ncount; |
|
| : |
: |
| r> swap 0 >r >r >r ; |
r> swap 0 >r >r >r ; |
| |
|
| (do) nlimit nstart -- gforth paren_do |
(do) ( nlimit nstart -- R:nlimit R:nstart ) gforth paren_do |
| /* or do it in high-level? 0.09/0.23% */ |
|
| *--rp = nlimit; |
|
| *--rp = nstart; |
|
| : |
: |
| r> swap rot >r >r >r ; |
r> swap rot >r >r >r ; |
| |
|
| (?do) nlimit nstart -- gforth paren_question_do |
(?do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth paren_question_do |
| *--rp = nlimit; |
#ifdef NO_IP |
| *--rp = nstart; |
INST_TAIL; |
| |
#endif |
| if (nstart == nlimit) { |
if (nstart == nlimit) { |
| IF_TOS(TOS = sp[0]); |
#ifdef NO_IP |
| goto branch; |
JUMP(a_target); |
| } |
#else |
| else { |
SET_IP((Xt *)a_target); |
| INC_IP(1); |
#endif |
| } |
} |
| : |
: |
| 2dup = |
2dup = |
| IF r> swap rot >r >r |
IF r> swap rot >r >r |
| dup @ + >r |
@ >r |
| ELSE r> swap rot >r >r |
ELSE r> swap rot >r >r |
| cell+ >r |
cell+ >r |
| THEN ; \ --> CORE-EXT |
THEN ; \ --> CORE-EXT |
| |
|
| \+has-xconds [IF] |
\+xconds |
| |
|
| (+do) nlimit nstart -- gforth paren_plus_do |
(+do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth paren_plus_do |
| *--rp = nlimit; |
#ifdef NO_IP |
| *--rp = nstart; |
INST_TAIL; |
| |
#endif |
| if (nstart >= nlimit) { |
if (nstart >= nlimit) { |
| IF_TOS(TOS = sp[0]); |
#ifdef NO_IP |
| goto branch; |
JUMP(a_target); |
| } |
#else |
| else { |
SET_IP((Xt *)a_target); |
| INC_IP(1); |
#endif |
| } |
} |
| : |
: |
| swap 2dup |
swap 2dup |
| r> swap >r swap >r |
r> swap >r swap >r |
| >= |
>= |
| IF |
IF |
| dup @ + |
@ |
| ELSE |
ELSE |
| cell+ |
cell+ |
| THEN >r ; |
THEN >r ; |
| |
|
| (u+do) ulimit ustart -- gforth paren_u_plus_do |
(u+do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth paren_u_plus_do |
| *--rp = ulimit; |
#ifdef NO_IP |
| *--rp = ustart; |
INST_TAIL; |
| |
#endif |
| if (ustart >= ulimit) { |
if (ustart >= ulimit) { |
| IF_TOS(TOS = sp[0]); |
#ifdef NO_IP |
| goto branch; |
JUMP(a_target); |
| } |
#else |
| else { |
SET_IP((Xt *)a_target); |
| INC_IP(1); |
#endif |
| } |
} |
| : |
: |
| swap 2dup |
swap 2dup |
| r> swap >r swap >r |
r> swap >r swap >r |
| u>= |
u>= |
| IF |
IF |
| dup @ + |
@ |
| ELSE |
ELSE |
| cell+ |
cell+ |
| THEN >r ; |
THEN >r ; |
| |
|
| (-do) nlimit nstart -- gforth paren_minus_do |
(-do) ( #a_target nlimit nstart -- R:nlimit R:nstart ) gforth paren_minus_do |
| *--rp = nlimit; |
#ifdef NO_IP |
| *--rp = nstart; |
INST_TAIL; |
| |
#endif |
| if (nstart <= nlimit) { |
if (nstart <= nlimit) { |
| IF_TOS(TOS = sp[0]); |
#ifdef NO_IP |
| goto branch; |
JUMP(a_target); |
| } |
#else |
| else { |
SET_IP((Xt *)a_target); |
| INC_IP(1); |
#endif |
| } |
} |
| : |
: |
| swap 2dup |
swap 2dup |
| r> swap >r swap >r |
r> swap >r swap >r |
| <= |
<= |
| IF |
IF |
| dup @ + |
@ |
| ELSE |
ELSE |
| cell+ |
cell+ |
| THEN >r ; |
THEN >r ; |
| |
|
| (u-do) ulimit ustart -- gforth paren_u_minus_do |
(u-do) ( #a_target ulimit ustart -- R:ulimit R:ustart ) gforth paren_u_minus_do |
| *--rp = ulimit; |
#ifdef NO_IP |
| *--rp = ustart; |
INST_TAIL; |
| |
#endif |
| if (ustart <= ulimit) { |
if (ustart <= ulimit) { |
| IF_TOS(TOS = sp[0]); |
#ifdef NO_IP |
| goto branch; |
JUMP(a_target); |
| } |
#else |
| else { |
SET_IP((Xt *)a_target); |
| INC_IP(1); |
#endif |
| } |
} |
| : |
: |
| swap 2dup |
swap 2dup |
| r> swap >r swap >r |
r> swap >r swap >r |
| u<= |
u<= |
| IF |
IF |
| dup @ + |
@ |
| ELSE |
ELSE |
| cell+ |
cell+ |
| THEN >r ; |
THEN >r ; |
| |
|
| \+[THEN] |
(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])); |
| |
|
| i -- n core |
|
| n = *rp; |
\+ |
| |
|
| |
\ don't make any assumptions where the return stack is!! |
| |
\ implement this in machine code if it should run quickly! |
| |
|
| |
i ( R:n -- R:n n ) core |
| : |
: |
| rp@ cell+ @ ; |
\ rp@ cell+ @ ; |
| |
r> r> tuck >r >r ; |
| |
|
| i' -- w gforth i_tick |
i' ( R:w R:w2 -- R:w R:w2 w ) gforth i_tick |
| ""loop end value"" |
|
| w = rp[1]; |
|
| : |
: |
| rp@ cell+ cell+ @ ; |
\ rp@ cell+ cell+ @ ; |
| |
r> r> r> dup itmp ! >r >r >r itmp @ ; |
| |
variable itmp |
| |
|
| j -- n core |
j ( R:w R:w1 R:w2 -- w R:w R:w1 R:w2 ) core |
| n = rp[2]; |
|
| : |
: |
| rp@ cell+ cell+ cell+ @ ; |
\ rp@ cell+ cell+ cell+ @ ; |
| |
r> r> r> r> dup itmp ! >r >r >r >r itmp @ ; |
| |
[IFUNDEF] itmp variable itmp [THEN] |
| |
|
| k -- n gforth |
k ( R:w R:w1 R:w2 R:w3 R:w4 -- w R:w R:w1 R:w2 R:w3 R:w4 ) gforth |
| n = rp[4]; |
|
| : |
: |
| rp@ [ 5 cells ] Literal + @ ; |
\ rp@ [ 5 cells ] Literal + @ ; |
| |
r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ; |
| |
[IFUNDEF] itmp variable itmp [THEN] |
| |
|
| |
\f[THEN] |
| |
|
| \ digit is high-level: 0/0% |
\ digit is high-level: 0/0% |
| |
|
| move c_from c_to ucount -- core |
\g strings |
| |
|
| |
move ( c_from c_to ucount -- ) core |
| |
""Copy the contents of @i{ucount} aus at @i{c-from} to |
| |
@i{c-to}. @code{move} works correctly even if the two areas overlap."" |
| |
/* !! note that the standard specifies addr, not c-addr */ |
| memmove(c_to,c_from,ucount); |
memmove(c_to,c_from,ucount); |
| /* make an Ifdef for bsd and others? */ |
/* make an Ifdef for bsd and others? */ |
| : |
: |
| >r 2dup u< IF r> cmove> ELSE r> cmove THEN ; |
>r 2dup u< IF r> cmove> ELSE r> cmove THEN ; |
| |
|
| cmove c_from c_to u -- string |
cmove ( c_from c_to u -- ) string c_move |
| while (u-- > 0) |
""Copy the contents of @i{ucount} characters from data space at |
| *c_to++ = *c_from++; |
@i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char} |
| |
from low address to high address; i.e., for overlapping areas it is |
| |
safe if @i{c-to}=<@i{c-from}."" |
| |
cmove(c_from,c_to,u); |
| : |
: |
| bounds ?DO dup c@ I c! 1+ LOOP drop ; |
bounds ?DO dup c@ I c! 1+ LOOP drop ; |
| |
|
| cmove> c_from c_to u -- string c_move_up |
cmove> ( c_from c_to u -- ) string c_move_up |
| while (u-- > 0) |
""Copy the contents of @i{ucount} characters from data space at |
| c_to[u] = c_from[u]; |
@i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char} |
| |
from high address to low address; i.e., for overlapping areas it is |
| |
safe if @i{c-to}>=@i{c-from}."" |
| |
cmove_up(c_from,c_to,u); |
| : |
: |
| dup 0= IF drop 2drop exit THEN |
dup 0= IF drop 2drop exit THEN |
| rot over + -rot bounds swap 1- |
rot over + -rot bounds swap 1- |
| DO 1- dup c@ I c! -1 +LOOP drop ; |
DO 1- dup c@ I c! -1 +LOOP drop ; |
| |
|
| fill c_addr u c -- core |
fill ( c_addr u c -- ) core |
| |
""Store @i{c} in @i{u} chars starting at @i{c-addr}."" |
| memset(c_addr,c,u); |
memset(c_addr,c,u); |
| : |
: |
| -rot bounds |
-rot bounds |
| ?DO dup I c! LOOP drop ; |
?DO dup I c! LOOP drop ; |
| |
|
| compare c_addr1 u1 c_addr2 u2 -- n string |
compare ( c_addr1 u1 c_addr2 u2 -- n ) string |
| ""Compare the strings lexicographically. If they are equal, n is 0; if |
""Compare two strings lexicographically. If they are equal, @i{n} is 0; if |
| the first string is smaller, n is -1; if the first string is larger, n |
the first string is smaller, @i{n} is -1; if the first string is larger, @i{n} |
| is 1. Currently this is based on the machine's character |
is 1. Currently this is based on the machine's character |
| comparison. In the future, this may change to considering the current |
comparison. In the future, this may change to consider the current |
| locale and its collation order."" |
locale and its collation order."" |
| n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2); |
/* close ' to keep fontify happy */ |
| if (n==0) |
n = compare(c_addr1, u1, c_addr2, u2); |
| n = u1-u2; |
|
| if (n<0) |
|
| n = -1; |
|
| else if (n>0) |
|
| n = 1; |
|
| : |
|
| rot 2dup - >r min swap -text dup |
|
| IF rdrop |
|
| ELSE drop r@ 0> |
|
| IF rdrop -1 |
|
| ELSE r> 1 and |
|
| THEN |
|
| THEN ; |
|
| |
|
| -text c_addr1 u c_addr2 -- n new dash_text |
|
| n = memcmp(c_addr1, c_addr2, u); |
|
| if (n<0) |
|
| n = -1; |
|
| else if (n>0) |
|
| n = 1; |
|
| : |
: |
| |
rot 2dup swap - >r min swap -text dup |
| |
IF rdrop ELSE drop r> sgn THEN ; |
| |
: -text ( c_addr1 u c_addr2 -- n ) |
| swap bounds |
swap bounds |
| ?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 |
?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 |
| ELSE c@ I c@ - unloop THEN -text-flag ; |
ELSE c@ I c@ - unloop THEN sgn ; |
| : -text-flag ( n -- -1/0/1 ) |
: sgn ( n -- -1/0/1 ) |
| dup 0< IF drop -1 ELSE 0> 1 and THEN ; |
dup 0= IF EXIT THEN 0< 2* 1+ ; |
| |
|
| toupper c1 -- c2 gforth |
\ -text is only used by replaced primitives now; move it elsewhere |
| |
\ -text ( c_addr1 u c_addr2 -- n ) new dash_text |
| |
\ n = memcmp(c_addr1, c_addr2, u); |
| |
\ if (n<0) |
| |
\ n = -1; |
| |
\ else if (n>0) |
| |
\ n = 1; |
| |
\ : |
| |
\ swap bounds |
| |
\ ?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 |
| |
\ ELSE c@ I c@ - unloop THEN sgn ; |
| |
\ : sgn ( n -- -1/0/1 ) |
| |
\ dup 0= IF EXIT THEN 0< 2* 1+ ; |
| |
|
| |
toupper ( c1 -- c2 ) gforth |
| |
""If @i{c1} is a lower-case character (in the current locale), @i{c2} |
| |
is the equivalent upper-case character. All other characters are unchanged."" |
| c2 = toupper(c1); |
c2 = toupper(c1); |
| : |
: |
| dup [char] a - [ char z char a - 1 + ] Literal u< bl and - ; |
dup [char] a - [ char z char a - 1 + ] Literal u< bl and - ; |
| |
|
| capscomp c_addr1 u c_addr2 -- n new |
capscompare ( c_addr1 u1 c_addr2 u2 -- n ) gforth |
| n = memcasecmp(c_addr1, c_addr2, u); /* !! use something that works in all locales */ |
""Compare two strings lexicographically. If they are equal, @i{n} is 0; if |
| if (n<0) |
the first string is smaller, @i{n} is -1; if the first string is larger, @i{n} |
| n = -1; |
is 1. Currently this is based on the machine's character |
| else if (n>0) |
comparison. In the future, this may change to consider the current |
| n = 1; |
locale and its collation order."" |
| : |
/* close ' to keep fontify happy */ |
| swap bounds |
n = capscompare(c_addr1, u1, c_addr2, u2); |
| ?DO dup c@ I c@ <> |
|
| IF dup c@ toupper I c@ toupper = |
|
| ELSE true THEN WHILE 1+ LOOP drop 0 |
|
| ELSE c@ toupper I c@ toupper - unloop THEN -text-flag ; |
|
| |
|
| -trailing c_addr u1 -- c_addr u2 string dash_trailing |
|
| u2 = u1; |
|
| while (c_addr[u2-1] == ' ') |
|
| u2--; |
|
| : |
|
| BEGIN 1- 2dup + c@ bl = WHILE |
|
| dup 0= UNTIL ELSE 1+ THEN ; |
|
| |
|
| /string c_addr1 u1 n -- c_addr2 u2 string slash_string |
/string ( c_addr1 u1 n -- c_addr2 u2 ) string slash_string |
| |
""Adjust the string specified by @i{c-addr1, u1} to remove @i{n} |
| |
characters from the start of the string."" |
| c_addr2 = c_addr1+n; |
c_addr2 = c_addr1+n; |
| u2 = u1-n; |
u2 = u1-n; |
| : |
: |
| tuck - >r + r> dup 0< IF - 0 THEN ; |
tuck - >r + r> dup 0< IF - 0 THEN ; |
| |
|
| + n1 n2 -- n core plus |
\g arith |
| |
|
| |
lit ( #w -- w ) gforth |
| |
: |
| |
r> dup @ swap cell+ >r ; |
| |
|
| |
+ ( n1 n2 -- n ) core plus |
| |
n = n1+n2; |
| |
|
| |
\ lit+ / lit_plus = lit + |
| |
|
| |
lit+ ( n1 #n2 -- n ) new lit_plus |
| |
#ifdef DEBUG |
| |
fprintf(stderr, "lit+ %08x\n", n2); |
| |
#endif |
| n = n1+n2; |
n = n1+n2; |
| |
|
| \ PFE-0.9.14 has it differently, but the next release will have it as follows |
\ PFE-0.9.14 has it differently, but the next release will have it as follows |
| under+ n1 n2 n3 -- n n2 gforth under_plus |
under+ ( n1 n2 n3 -- n n2 ) gforth under_plus |
| ""add @var{n3} to @var{n1} (giving @var{n})"" |
""add @i{n3} to @i{n1} (giving @i{n})"" |
| n = n1+n3; |
n = n1+n3; |
| : |
: |
| rot + swap ; |
rot + swap ; |
| |
|
| - n1 n2 -- n core minus |
- ( n1 n2 -- n ) core minus |
| n = n1-n2; |
n = n1-n2; |
| : |
: |
| negate + ; |
negate + ; |
| |
|
| negate n1 -- n2 core |
negate ( n1 -- n2 ) core |
| /* use minus as alias */ |
/* use minus as alias */ |
| n2 = -n1; |
n2 = -n1; |
| : |
: |
| invert 1+ ; |
invert 1+ ; |
| |
|
| 1+ n1 -- n2 core one_plus |
1+ ( n1 -- n2 ) core one_plus |
| n2 = n1+1; |
n2 = n1+1; |
| : |
: |
| 1 + ; |
1 + ; |
| |
|
| 1- n1 -- n2 core one_minus |
1- ( n1 -- n2 ) core one_minus |
| n2 = n1-1; |
n2 = n1-1; |
| : |
: |
| 1 - ; |
1 - ; |
| |
|
| max n1 n2 -- n core |
max ( n1 n2 -- n ) core |
| if (n1<n2) |
if (n1<n2) |
| n = n2; |
n = n2; |
| else |
else |
| : |
: |
| 2dup < IF swap THEN drop ; |
2dup < IF swap THEN drop ; |
| |
|
| min n1 n2 -- n core |
min ( n1 n2 -- n ) core |
| if (n1<n2) |
if (n1<n2) |
| n = n1; |
n = n1; |
| else |
else |
| : |
: |
| 2dup > IF swap THEN drop ; |
2dup > IF swap THEN drop ; |
| |
|
| abs n1 -- n2 core |
abs ( n -- u ) core |
| if (n1<0) |
if (n<0) |
| n2 = -n1; |
u = -n; |
| else |
else |
| n2 = n1; |
u = n; |
| : |
: |
| dup 0< IF negate THEN ; |
dup 0< IF negate THEN ; |
| |
|
| * n1 n2 -- n core star |
* ( n1 n2 -- n ) core star |
| n = n1*n2; |
n = n1*n2; |
| : |
: |
| um* drop ; |
um* drop ; |
| |
|
| / n1 n2 -- n core slash |
/ ( n1 n2 -- n ) core slash |
| n = n1/n2; |
n = n1/n2; |
| |
if (CHECK_DIVISION_SW && n2 == 0) |
| |
throw(BALL_DIVZERO); |
| |
if (CHECK_DIVISION_SW && n2 == -1 && n1 == CELL_MIN) |
| |
throw(BALL_RESULTRANGE); |
| |
if (FLOORED_DIV && ((n1^n2) < 0) && (n1%n2 != 0)) |
| |
n--; |
| : |
: |
| /mod nip ; |
/mod nip ; |
| |
|
| mod n1 n2 -- n core |
mod ( n1 n2 -- n ) core |
| n = n1%n2; |
n = n1%n2; |
| |
if (CHECK_DIVISION_SW && n2 == 0) |
| |
throw(BALL_DIVZERO); |
| |
if (CHECK_DIVISION_SW && n2 == -1 && n1 == CELL_MIN) |
| |
throw(BALL_RESULTRANGE); |
| |
if(FLOORED_DIV && ((n1^n2) < 0) && n!=0) n += n2; |
| : |
: |
| /mod drop ; |
/mod drop ; |
| |
|
| /mod n1 n2 -- n3 n4 core slash_mod |
/mod ( n1 n2 -- n3 n4 ) core slash_mod |
| n4 = n1/n2; |
n4 = n1/n2; |
| n3 = n1%n2; /* !! is this correct? look into C standard! */ |
n3 = n1%n2; /* !! is this correct? look into C standard! */ |
| |
if (CHECK_DIVISION_SW && n2 == 0) |
| |
throw(BALL_DIVZERO); |
| |
if (CHECK_DIVISION_SW && n2 == -1 && n1 == CELL_MIN) |
| |
throw(BALL_RESULTRANGE); |
| |
if (FLOORED_DIV && ((n1^n2) < 0) && n3!=0) { |
| |
n4--; |
| |
n3+=n2; |
| |
} |
| : |
: |
| >r s>d r> fm/mod ; |
>r s>d r> fm/mod ; |
| |
|
| 2* n1 -- n2 core two_star |
*/mod ( n1 n2 n3 -- n4 n5 ) core star_slash_mod |
| |
""n1*n2=n3*n5+n4, with the intermediate result (n1*n2) being double."" |
| |
#ifdef BUGGY_LL_MUL |
| |
DCell d = mmul(n1,n2); |
| |
#else |
| |
DCell d = (DCell)n1 * (DCell)n2; |
| |
#endif |
| |
#ifdef ASM_SM_SLASH_REM |
| |
ASM_SM_SLASH_REM(DLO(d), DHI(d), n3, n4, n5); |
| |
if (FLOORED_DIV && ((DHI(d)^n3)<0) && n4!=0) { |
| |
if (CHECK_DIVISION && n5 == CELL_MIN) |
| |
throw(BALL_RESULTRANGE); |
| |
n5--; |
| |
n4+=n3; |
| |
} |
| |
#else |
| |
DCell r = FLOORED_DIV ? fmdiv(d,n3) : smdiv(d,n3); |
| |
n4=DHI(r); |
| |
n5=DLO(r); |
| |
#endif |
| |
: |
| |
>r m* r> fm/mod ; |
| |
|
| |
*/ ( n1 n2 n3 -- n4 ) core star_slash |
| |
""n4=(n1*n2)/n3, with the intermediate result being double."" |
| |
#ifdef BUGGY_LL_MUL |
| |
DCell d = mmul(n1,n2); |
| |
#else |
| |
DCell d = (DCell)n1 * (DCell)n2; |
| |
#endif |
| |
#ifdef ASM_SM_SLASH_REM |
| |
Cell remainder; |
| |
ASM_SM_SLASH_REM(DLO(d), DHI(d), n3, remainder, n4); |
| |
if (FLOORED_DIV && ((DHI(d)^n3)<0) && remainder!=0) { |
| |
if (CHECK_DIVISION && n4 == CELL_MIN) |
| |
throw(BALL_RESULTRANGE); |
| |
n4--; |
| |
} |
| |
#else |
| |
DCell r = FLOORED_DIV ? fmdiv(d,n3) : smdiv(d,n3); |
| |
n4=DLO(r); |
| |
#endif |
| |
: |
| |
*/mod nip ; |
| |
|
| |
2* ( n1 -- n2 ) core two_star |
| |
""Shift left by 1; also works on unsigned numbers"" |
| n2 = 2*n1; |
n2 = 2*n1; |
| : |
: |
| dup + ; |
dup + ; |
| |
|
| 2/ n1 -- n2 core two_slash |
2/ ( n1 -- n2 ) core two_slash |
| /* !! is this still correct? */ |
""Arithmetic shift right by 1. For signed numbers this is a floored |
| |
division by 2 (note that @code{/} not necessarily floors)."" |
| n2 = n1>>1; |
n2 = n1>>1; |
| : |
: |
| dup MINI and IF 1 ELSE 0 THEN |
dup MINI and IF 1 ELSE 0 THEN |
| [ bits/byte cell * 1- ] literal |
[ bits/char cell * 1- ] literal |
| 0 DO 2* swap dup 2* >r U-HIGHBIT and |
0 DO 2* swap dup 2* >r MINI and |
| IF 1 ELSE 0 THEN or r> swap |
IF 1 ELSE 0 THEN or r> swap |
| LOOP nip ; |
LOOP nip ; |
| |
|
| fm/mod d1 n1 -- n2 n3 core f_m_slash_mod |
fm/mod ( d1 n1 -- n2 n3 ) core f_m_slash_mod |
| ""floored division: d1 = n3*n1+n2, n1>n2>=0 or 0>=n2>n1"" |
""Floored division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, @i{n1}>@i{n2}>=0 or 0>=@i{n2}>@i{n1}."" |
| #ifdef BUGGY_LONG_LONG |
#ifdef ASM_SM_SLASH_REM |
| DCell r = fmdiv(d1,n1); |
ASM_SM_SLASH_REM(DLO(d1), DHI(d1), n1, n2, n3); |
| n2=r.hi; |
if (((DHI(d1)^n1)<0) && n2!=0) { |
| n3=r.lo; |
if (CHECK_DIVISION && n3 == CELL_MIN) |
| #else |
throw(BALL_RESULTRANGE); |
| /* assumes that the processor uses either floored or symmetric division */ |
|
| n3 = d1/n1; |
|
| n2 = d1%n1; |
|
| /* note that this 1%-3>0 is optimized by the compiler */ |
|
| if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) { |
|
| n3--; |
n3--; |
| n2+=n1; |
n2+=n1; |
| } |
} |
| #endif |
#else /* !defined(ASM_SM_SLASH_REM) */ |
| |
DCell r = fmdiv(d1,n1); |
| |
n2=DHI(r); |
| |
n3=DLO(r); |
| |
#endif /* !defined(ASM_SM_SLASH_REM) */ |
| : |
: |
| dup >r dup 0< IF negate >r dnegate r> THEN |
dup >r dup 0< IF negate >r dnegate r> THEN |
| over 0< IF tuck + swap THEN |
over 0< IF tuck + swap THEN |
| um/mod |
um/mod |
| r> 0< IF swap negate swap THEN ; |
r> 0< IF swap negate swap THEN ; |
| |
|
| sm/rem d1 n1 -- n2 n3 core s_m_slash_rem |
sm/rem ( d1 n1 -- n2 n3 ) core s_m_slash_rem |
| ""symmetric division: d1 = n3*n1+n2, sign(n2)=sign(d1) or 0"" |
""Symmetric division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, sign(@i{n2})=sign(@i{d1}) or 0."" |
| #ifdef BUGGY_LONG_LONG |
#ifdef ASM_SM_SLASH_REM |
| |
ASM_SM_SLASH_REM(DLO(d1), DHI(d1), n1, n2, n3); |
| |
#else /* !defined(ASM_SM_SLASH_REM) */ |
| DCell r = smdiv(d1,n1); |
DCell r = smdiv(d1,n1); |
| n2=r.hi; |
n2=DHI(r); |
| n3=r.lo; |
n3=DLO(r); |
| #else |
#endif /* !defined(ASM_SM_SLASH_REM) */ |
| /* assumes that the processor uses either floored or symmetric division */ |
|
| n3 = d1/n1; |
|
| n2 = d1%n1; |
|
| /* note that this 1%-3<0 is optimized by the compiler */ |
|
| if (1%-3<0 && (d1<0) != (n1<0) && n2!=0) { |
|
| n3++; |
|
| n2-=n1; |
|
| } |
|
| #endif |
|
| : |
: |
| over >r dup >r abs -rot |
over >r dup >r abs -rot |
| dabs rot um/mod |
dabs rot um/mod |
| r> r@ xor 0< IF negate THEN |
r> r@ xor 0< IF negate THEN |
| r> 0< IF swap negate swap THEN ; |
r> 0< IF swap negate swap THEN ; |
| |
|
| m* n1 n2 -- d core m_star |
m* ( n1 n2 -- d ) core m_star |
| #ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LL_MUL |
| d = mmul(n1,n2); |
d = mmul(n1,n2); |
| #else |
#else |
| d = (DCell)n1 * (DCell)n2; |
d = (DCell)n1 * (DCell)n2; |
| 2dup swap 0< and >r |
2dup swap 0< and >r |
| um* r> - r> - ; |
um* r> - r> - ; |
| |
|
| um* u1 u2 -- ud core u_m_star |
um* ( u1 u2 -- ud ) core u_m_star |
| /* use u* as alias */ |
/* use u* as alias */ |
| #ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LL_MUL |
| ud = ummul(u1,u2); |
ud = ummul(u1,u2); |
| #else |
#else |
| ud = (UDCell)u1 * (UDCell)u2; |
ud = (UDCell)u1 * (UDCell)u2; |
| #endif |
#endif |
| : |
: |
| >r >r 0 0 r> r> [ 8 cells ] literal 0 |
0 -rot dup [ 8 cells ] literal - |
| DO |
DO |
| over >r dup >r 0< and d2*+ drop |
dup 0< I' and d2*+ drop |
| r> 2* r> swap |
LOOP ; |
| LOOP 2drop ; |
|
| : d2*+ ( ud n -- ud+n c ) |
: d2*+ ( ud n -- ud+n c ) |
| over MINI |
over MINI |
| and >r >r 2dup d+ swap r> + swap r> ; |
and >r >r 2dup d+ swap r> + swap r> ; |
| |
|
| um/mod ud u1 -- u2 u3 core u_m_slash_mod |
um/mod ( ud u1 -- u2 u3 ) core u_m_slash_mod |
| #ifdef BUGGY_LONG_LONG |
""ud=u3*u1+u2, u1>u2>=0"" |
| |
#ifdef ASM_UM_SLASH_MOD |
| |
ASM_UM_SLASH_MOD(DLO(ud), DHI(ud), u1, u2, u3); |
| |
#else /* !defined(ASM_UM_SLASH_MOD) */ |
| UDCell r = umdiv(ud,u1); |
UDCell r = umdiv(ud,u1); |
| u2=r.hi; |
u2=DHI(r); |
| u3=r.lo; |
u3=DLO(r); |
| #else |
#endif /* !defined(ASM_UM_SLASH_MOD) */ |
| u3 = ud/u1; |
|
| u2 = ud%u1; |
|
| #endif |
|
| : |
: |
| 0 swap [ 8 cells 1 + ] literal 0 |
0 swap [ 8 cells 1 + ] literal 0 |
| ?DO >r /modstep r> |
?DO /modstep |
| LOOP drop swap 1 rshift or swap ; |
LOOP drop swap 1 rshift or swap ; |
| : /modstep ( ud c R: u -- ud-?u c R: u ) |
: /modstep ( ud c R: u -- ud-?u c R: u ) |
| over I' u< 0= or IF I' - 1 ELSE 0 THEN d2*+ ; |
>r over r@ u< 0= or IF r@ - 1 ELSE 0 THEN d2*+ r> ; |
| : d2*+ ( ud n -- ud+n c ) |
: d2*+ ( ud n -- ud+n c ) |
| over MINI |
over MINI |
| and >r >r 2dup d+ swap r> + swap r> ; |
and >r >r 2dup d+ swap r> + swap r> ; |
| |
|
| m+ d1 n -- d2 double m_plus |
m+ ( d1 n -- d2 ) double m_plus |
| #ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LL_ADD |
| d2.lo = d1.lo+n; |
DLO_IS(d2, DLO(d1)+n); |
| d2.hi = d1.hi - (n<0) + (d2.lo<d1.lo); |
DHI_IS(d2, DHI(d1) - (n<0) + (DLO(d2)<DLO(d1))); |
| #else |
#else |
| d2 = d1+n; |
d2 = d1+n; |
| #endif |
#endif |
| : |
: |
| s>d d+ ; |
s>d d+ ; |
| |
|
| d+ d1 d2 -- d double d_plus |
d+ ( d1 d2 -- d ) double d_plus |
| #ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LL_ADD |
| d.lo = d1.lo+d2.lo; |
DLO_IS(d, DLO(d1) + DLO(d2)); |
| d.hi = d1.hi + d2.hi + (d.lo<d1.lo); |
DHI_IS(d, DHI(d1) + DHI(d2) + (d.lo<DLO(d1))); |
| #else |
#else |
| d = d1+d2; |
d = d1+d2; |
| #endif |
#endif |
| : |
: |
| rot + >r tuck + swap over u> r> swap - ; |
rot + >r tuck + swap over u> r> swap - ; |
| |
|
| d- d1 d2 -- d double d_minus |
d- ( d1 d2 -- d ) double d_minus |
| #ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LL_ADD |
| d.lo = d1.lo - d2.lo; |
DLO_IS(d, DLO(d1) - DLO(d2)); |
| d.hi = d1.hi-d2.hi-(d1.lo<d2.lo); |
DHI_IS(d, DHI(d1)-DHI(d2)-(DLO(d1)<DLO(d2))); |
| #else |
#else |
| d = d1-d2; |
d = d1-d2; |
| #endif |
#endif |
| : |
: |
| dnegate d+ ; |
dnegate d+ ; |
| |
|
| dnegate d1 -- d2 double |
dnegate ( d1 -- d2 ) double d_negate |
| /* use dminus as alias */ |
/* use dminus as alias */ |
| #ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LL_ADD |
| d2 = dnegate(d1); |
d2 = dnegate(d1); |
| #else |
#else |
| d2 = -d1; |
d2 = -d1; |
| : |
: |
| invert swap negate tuck 0= - ; |
invert swap negate tuck 0= - ; |
| |
|
| d2* d1 -- d2 double d_two_star |
d2* ( d1 -- d2 ) double d_two_star |
| #ifdef BUGGY_LONG_LONG |
""Shift left by 1; also works on unsigned numbers"" |
| d2.lo = d1.lo<<1; |
d2 = DLSHIFT(d1,1); |
| d2.hi = (d1.hi<<1) | (d1.lo>>(CELL_BITS-1)); |
|
| #else |
|
| d2 = 2*d1; |
|
| #endif |
|
| : |
: |
| 2dup d+ ; |
2dup d+ ; |
| |
|
| d2/ d1 -- d2 double d_two_slash |
d2/ ( d1 -- d2 ) double d_two_slash |
| #ifdef BUGGY_LONG_LONG |
""Arithmetic shift right by 1. For signed numbers this is a floored |
| d2.hi = d1.hi>>1; |
division by 2."" |
| d2.lo= (d1.lo>>1) | (d1.hi<<(CELL_BITS-1)); |
#ifdef BUGGY_LL_SHIFT |
| |
DHI_IS(d2, DHI(d1)>>1); |
| |
DLO_IS(d2, (DLO(d1)>>1) | (DHI(d1)<<(CELL_BITS-1))); |
| #else |
#else |
| d2 = d1>>1; |
d2 = d1>>1; |
| #endif |
#endif |
| dup 1 and >r 2/ swap 2/ [ 1 8 cells 1- lshift 1- ] Literal and |
dup 1 and >r 2/ swap 2/ [ 1 8 cells 1- lshift 1- ] Literal and |
| r> IF [ 1 8 cells 1- lshift ] Literal + THEN swap ; |
r> IF [ 1 8 cells 1- lshift ] Literal + THEN swap ; |
| |
|
| and w1 w2 -- w core |
and ( w1 w2 -- w ) core |
| w = w1&w2; |
w = w1&w2; |
| |
|
| or w1 w2 -- w core |
or ( w1 w2 -- w ) core |
| w = w1|w2; |
w = w1|w2; |
| : |
: |
| invert swap invert and invert ; |
invert swap invert and invert ; |
| |
|
| xor w1 w2 -- w core |
xor ( w1 w2 -- w ) core x_or |
| w = w1^w2; |
w = w1^w2; |
| |
|
| invert w1 -- w2 core |
invert ( w1 -- w2 ) core |
| w2 = ~w1; |
w2 = ~w1; |
| : |
: |
| MAXU xor ; |
MAXU xor ; |
| |
|
| rshift u1 n -- u2 core |
rshift ( u1 n -- u2 ) core r_shift |
| |
""Logical shift right by @i{n} bits."" |
| |
#ifdef BROKEN_SHIFT |
| |
u2 = rshift(u1, n); |
| |
#else |
| u2 = u1>>n; |
u2 = u1>>n; |
| |
#endif |
| : |
: |
| 0 ?DO 2/ MAXI and LOOP ; |
0 ?DO 2/ MAXI and LOOP ; |
| |
|
| lshift u1 n -- u2 core |
lshift ( u1 n -- u2 ) core l_shift |
| |
#ifdef BROKEN_SHIFT |
| |
u2 = lshift(u1, n); |
| |
#else |
| u2 = u1<<n; |
u2 = u1<<n; |
| |
#endif |
| : |
: |
| 0 ?DO 2* LOOP ; |
0 ?DO 2* LOOP ; |
| |
|
| |
umax ( u1 u2 -- u ) core |
| |
if (u1<u2) |
| |
u = u2; |
| |
else |
| |
u = u1; |
| |
: |
| |
2dup u< IF swap THEN drop ; |
| |
|
| |
umin ( u1 u2 -- u ) core |
| |
if (u1<u2) |
| |
u = u1; |
| |
else |
| |
u = u2; |
| |
: |
| |
2dup u> IF swap THEN drop ; |
| |
|
| |
\g compare |
| |
|
| \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...) |
\ comparisons(prefix, args, prefix, arg1, arg2, wordsets...) |
| define(comparisons, |
define(comparisons, |
| $1= $2 -- f $6 $3equals |
$1= ( $2 -- f ) $6 $3equals |
| f = FLAG($4==$5); |
f = FLAG($4==$5); |
| : |
: |
| [ char $1x char 0 = [IF] |
[ char $1x char 0 = [IF] |
| ] xor 0= [ |
] xor 0= [ |
| [THEN] ] ; |
[THEN] ] ; |
| |
|
| $1<> $2 -- f $7 $3different |
$1<> ( $2 -- f ) $7 $3not_equals |
| f = FLAG($4!=$5); |
f = FLAG($4!=$5); |
| : |
: |
| [ char $1x char 0 = [IF] |
[ char $1x char 0 = [IF] |
| ] xor 0<> [ |
] xor 0<> [ |
| [THEN] ] ; |
[THEN] ] ; |
| |
|
| $1< $2 -- f $8 $3less |
$1< ( $2 -- f ) $8 $3less_than |
| f = FLAG($4<$5); |
f = FLAG($4<$5); |
| : |
: |
| [ char $1x char 0 = [IF] |
[ char $1x char 0 = [IF] |
| [THEN] |
[THEN] |
| [THEN] ] ; |
[THEN] ] ; |
| |
|
| $1> $2 -- f $9 $3greater |
$1> ( $2 -- f ) $9 $3greater_than |
| f = FLAG($4>$5); |
f = FLAG($4>$5); |
| : |
: |
| [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ] |
[ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ] |
| $1< ; |
$1< ; |
| |
|
| $1<= $2 -- f gforth $3less_or_equal |
$1<= ( $2 -- f ) gforth $3less_or_equal |
| f = FLAG($4<=$5); |
f = FLAG($4<=$5); |
| : |
: |
| $1> 0= ; |
$1> 0= ; |
| |
|
| $1>= $2 -- f gforth $3greater_or_equal |
$1>= ( $2 -- f ) gforth $3greater_or_equal |
| f = FLAG($4>=$5); |
f = FLAG($4>=$5); |
| : |
: |
| [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ] |
[ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ] |
| |
|
| \ dcomparisons(prefix, args, prefix, arg1, arg2, wordsets...) |
\ dcomparisons(prefix, args, prefix, arg1, arg2, wordsets...) |
| define(dcomparisons, |
define(dcomparisons, |
| $1= $2 -- f $6 $3equals |
$1= ( $2 -- f ) $6 $3equals |
| #ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LL_CMP |
| f = FLAG($4.lo==$5.lo && $4.hi==$5.hi); |
f = FLAG($4.lo==$5.lo && $4.hi==$5.hi); |
| #else |
#else |
| f = FLAG($4==$5); |
f = FLAG($4==$5); |
| #endif |
#endif |
| |
|
| $1<> $2 -- f $7 $3different |
$1<> ( $2 -- f ) $7 $3not_equals |
| #ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LL_CMP |
| f = FLAG($4.lo!=$5.lo || $4.hi!=$5.hi); |
f = FLAG($4.lo!=$5.lo || $4.hi!=$5.hi); |
| #else |
#else |
| f = FLAG($4!=$5); |
f = FLAG($4!=$5); |
| #endif |
#endif |
| |
|
| $1< $2 -- f $8 $3less |
$1< ( $2 -- f ) $8 $3less_than |
| #ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LL_CMP |
| f = FLAG($4.hi==$5.hi ? $4.lo<$5.lo : $4.hi<$5.hi); |
f = FLAG($4.hi==$5.hi ? $4.lo<$5.lo : $4.hi<$5.hi); |
| #else |
#else |
| f = FLAG($4<$5); |
f = FLAG($4<$5); |
| #endif |
#endif |
| |
|
| $1> $2 -- f $9 $3greater |
$1> ( $2 -- f ) $9 $3greater_than |
| #ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LL_CMP |
| f = FLAG($4.hi==$5.hi ? $4.lo>$5.lo : $4.hi>$5.hi); |
f = FLAG($4.hi==$5.hi ? $4.lo>$5.lo : $4.hi>$5.hi); |
| #else |
#else |
| f = FLAG($4>$5); |
f = FLAG($4>$5); |
| #endif |
#endif |
| |
|
| $1<= $2 -- f gforth $3less_or_equal |
$1<= ( $2 -- f ) gforth $3less_or_equal |
| #ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LL_CMP |
| f = FLAG($4.hi==$5.hi ? $4.lo<=$5.lo : $4.hi<=$5.hi); |
f = FLAG($4.hi==$5.hi ? $4.lo<=$5.lo : $4.hi<=$5.hi); |
| #else |
#else |
| f = FLAG($4<=$5); |
f = FLAG($4<=$5); |
| #endif |
#endif |
| |
|
| $1>= $2 -- f gforth $3greater_or_equal |
$1>= ( $2 -- f ) gforth $3greater_or_equal |
| #ifdef BUGGY_LONG_LONG |
#ifdef BUGGY_LL_CMP |
| f = FLAG($4.hi==$5.hi ? $4.lo>=$5.lo : $4.hi>=$5.hi); |
f = FLAG($4.hi==$5.hi ? $4.lo>=$5.lo : $4.hi>=$5.hi); |
| #else |
#else |
| f = FLAG($4>=$5); |
f = FLAG($4>=$5); |
| |
|
| ) |
) |
| |
|
| \+has-dcomps [IF] |
\+dcomps |
| |
|
| dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth) |
dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth) |
| dcomparisons(d0, d, d_zero_, d, DZERO, double, gforth, double, gforth) |
dcomparisons(d0, d, d_zero_, d, DZERO, double, gforth, double, gforth) |
| dcomparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth) |
dcomparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth) |
| |
|
| \+[THEN] |
\+ |
| |
|
| within u1 u2 u3 -- f core-ext |
within ( u1 u2 u3 -- f ) core-ext |
| |
""u2=<u1<u3 or: u3=<u2 and u1 is not in [u3,u2). This works for |
| |
unsigned and signed numbers (but not a mixture). Another way to think |
| |
about this word is to consider the numbers as a circle (wrapping |
| |
around from @code{max-u} to 0 for unsigned, and from @code{max-n} to |
| |
min-n for signed numbers); now consider the range from u2 towards |
| |
increasing numbers up to and excluding u3 (giving an empty range if |
| |
u2=u3); if u1 is in this range, @code{within} returns true."" |
| f = FLAG(u1-u2 < u3-u2); |
f = FLAG(u1-u2 < u3-u2); |
| : |
: |
| over - >r - r> u< ; |
over - >r - r> u< ; |
| |
|
| sp@ -- a_addr gforth spat |
\g stack |
| a_addr = sp+1; |
|
| |
useraddr ( #u -- a_addr ) new |
| |
a_addr = (Cell *)(up+u); |
| |
|
| |
up! ( a_addr -- ) gforth up_store |
| |
gforth_UP=up=(Address)a_addr; |
| |
: |
| |
up ! ; |
| |
Variable UP |
| |
|
| |
sp@ ( S:... -- a_addr ) gforth sp_fetch |
| |
a_addr = sp; |
| |
|
| sp! a_addr -- gforth spstore |
sp! ( a_addr -- S:... ) gforth sp_store |
| sp = a_addr; |
sp = a_addr; |
| /* works with and without TOS caching */ |
|
| |
|
| rp@ -- a_addr gforth rpat |
rp@ ( -- a_addr ) gforth rp_fetch |
| a_addr = rp; |
a_addr = rp; |
| |
|
| rp! a_addr -- gforth rpstore |
rp! ( a_addr -- ) gforth rp_store |
| rp = a_addr; |
rp = a_addr; |
| |
|
| \+has-floats [IF] |
\+floating |
| |
|
| fp@ -- f_addr gforth fp_fetch |
fp@ ( f:... -- f_addr ) gforth fp_fetch |
| f_addr = fp; |
f_addr = fp; |
| |
|
| fp! f_addr -- gforth fp_store |
fp! ( f_addr -- f:... ) gforth fp_store |
| fp = f_addr; |
fp = f_addr; |
| |
|
| \+[THEN] |
\+ |
| |
|
| ;s -- gforth semis |
|
| ip = (Xt *)(*rp++); |
|
| NEXT_P0; |
|
| |
|
| >r w -- core to_r |
>r ( w -- R:w ) core to_r |
| *--rp = w; |
|
| : |
: |
| (>r) ; |
(>r) ; |
| : (>r) rp@ cell+ @ rp@ ! rp@ cell+ ! ; |
: (>r) rp@ cell+ @ rp@ ! rp@ cell+ ! ; |
| |
|
| r> -- w core r_from |
r> ( R:w -- w ) core r_from |
| w = *rp++; |
|
| : |
: |
| rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ; |
rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ; |
| Create (rdrop) ' ;s A, |
Create (rdrop) ' ;s A, |
| |
|
| rdrop -- gforth |
rdrop ( R:w -- ) gforth |
| rp++; |
|
| : |
: |
| r> r> drop >r ; |
r> r> drop >r ; |
| |
|
| 2>r w1 w2 -- core-ext two_to_r |
2>r ( d -- R:d ) core-ext two_to_r |
| *--rp = w1; |
|
| *--rp = w2; |
|
| : |
: |
| swap r> swap >r swap >r >r ; |
swap r> swap >r swap >r >r ; |
| |
|
| 2r> -- w1 w2 core-ext two_r_from |
2r> ( R:d -- d ) core-ext two_r_from |
| w2 = *rp++; |
|
| w1 = *rp++; |
|
| : |
: |
| r> r> swap r> swap >r swap ; |
r> r> swap r> swap >r swap ; |
| |
|
| 2r@ -- w1 w2 core-ext two_r_fetch |
2r@ ( R:d -- R:d d ) core-ext two_r_fetch |
| w2 = rp[0]; |
|
| w1 = rp[1]; |
|
| : |
: |
| i' j ; |
i' j ; |
| |
|
| 2rdrop -- gforth two_r_drop |
2rdrop ( R:d -- ) gforth two_r_drop |
| rp+=2; |
|
| : |
: |
| r> r> drop r> drop >r ; |
r> r> drop r> drop >r ; |
| |
|
| over w1 w2 -- w1 w2 w1 core |
over ( w1 w2 -- w1 w2 w1 ) core |
| : |
: |
| sp@ cell+ @ ; |
sp@ cell+ @ ; |
| |
|
| drop w -- core |
drop ( w -- ) core |
| : |
: |
| IF THEN ; |
IF THEN ; |
| |
|
| swap w1 w2 -- w2 w1 core |
swap ( w1 w2 -- w2 w1 ) core |
| : |
: |
| >r (swap) ! r> (swap) @ ; |
>r (swap) ! r> (swap) @ ; |
| Variable (swap) |
Variable (swap) |
| |
|
| dup w -- w w core |
dup ( w -- w w ) core dupe |
| : |
: |
| sp@ @ ; |
sp@ @ ; |
| |
|
| rot w1 w2 w3 -- w2 w3 w1 core rote |
rot ( w1 w2 w3 -- w2 w3 w1 ) core rote |
| : |
: |
| [ defined? (swap) [IF] ] |
[ defined? (swap) [IF] ] |
| (swap) ! (rot) ! >r (rot) @ (swap) @ r> ; |
(swap) ! (rot) ! >r (rot) @ (swap) @ r> ; |
| >r swap r> swap ; |
>r swap r> swap ; |
| [THEN] |
[THEN] |
| |
|
| -rot w1 w2 w3 -- w3 w1 w2 gforth not_rote |
-rot ( w1 w2 w3 -- w3 w1 w2 ) gforth not_rote |
| : |
: |
| rot rot ; |
rot rot ; |
| |
|
| nip w1 w2 -- w2 core-ext |
nip ( w1 w2 -- w2 ) core-ext |
| : |
: |
| >r drop r> ; |
swap drop ; |
| |
|
| tuck w1 w2 -- w2 w1 w2 core-ext |
tuck ( w1 w2 -- w2 w1 w2 ) core-ext |
| : |
: |
| swap over ; |
swap over ; |
| |
|
| ?dup w -- w core question_dupe |
?dup ( w -- S:... w ) core question_dupe |
| |
""Actually the stack effect is: @code{( w -- 0 | w w )}. It performs a |
| |
@code{dup} if w is nonzero."" |
| if (w!=0) { |
if (w!=0) { |
| IF_TOS(*sp-- = w;) |
|
| #ifndef USE_TOS |
|
| *--sp = w; |
*--sp = w; |
| #endif |
|
| } |
} |
| : |
: |
| dup IF dup THEN ; |
dup IF dup THEN ; |
| |
|
| pick u -- w core-ext |
pick ( S:... u -- S:... w ) core-ext |
| w = sp[u+1]; |
""Actually the stack effect is @code{ x0 ... xu u -- x0 ... xu x0 }."" |
| |
w = sp[u]; |
| : |
: |
| 1+ cells sp@ + @ ; |
1+ cells sp@ + @ ; |
| |
|
| 2drop w1 w2 -- core two_drop |
2drop ( w1 w2 -- ) core two_drop |
| : |
: |
| drop drop ; |
drop drop ; |
| |
|
| 2dup w1 w2 -- w1 w2 w1 w2 core two_dupe |
2dup ( w1 w2 -- w1 w2 w1 w2 ) core two_dupe |
| : |
: |
| over over ; |
over over ; |
| |
|
| 2over w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2 core two_over |
2over ( w1 w2 w3 w4 -- w1 w2 w3 w4 w1 w2 ) core two_over |
| : |
: |
| 3 pick 3 pick ; |
3 pick 3 pick ; |
| |
|
| 2swap w1 w2 w3 w4 -- w3 w4 w1 w2 core two_swap |
2swap ( w1 w2 w3 w4 -- w3 w4 w1 w2 ) core two_swap |
| : |
: |
| rot >r rot r> ; |
rot >r rot r> ; |
| |
|
| 2rot w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2 double-ext two_rote |
2rot ( w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2 ) double-ext two_rote |
| : |
: |
| >r >r 2swap r> r> 2swap ; |
>r >r 2swap r> r> 2swap ; |
| |
|
| 2nip w1 w2 w3 w4 -- w3 w4 gforth two_nip |
2nip ( w1 w2 w3 w4 -- w3 w4 ) gforth two_nip |
| : |
: |
| 2swap 2drop ; |
2swap 2drop ; |
| |
|
| 2tuck w1 w2 w3 w4 -- w3 w4 w1 w2 w3 w4 gforth two_tuck |
2tuck ( w1 w2 w3 w4 -- w3 w4 w1 w2 w3 w4 ) gforth two_tuck |
| : |
: |
| 2swap 2over ; |
2swap 2over ; |
| |
|
| \ toggle is high-level: 0.11/0.42% |
\ toggle is high-level: 0.11/0.42% |
| |
|
| @ a_addr -- w core fetch |
\g memory |
| |
|
| |
@ ( a_addr -- w ) core fetch |
| |
""@i{w} is the cell stored at @i{a_addr}."" |
| w = *a_addr; |
w = *a_addr; |
| |
|
| ! w a_addr -- core store |
\ lit@ / lit_fetch = lit @ |
| |
|
| |
lit@ ( #a_addr -- w ) new lit_fetch |
| |
w = *a_addr; |
| |
|
| |
! ( w a_addr -- ) core store |
| |
""Store @i{w} into the cell at @i{a-addr}."" |
| *a_addr = w; |
*a_addr = w; |
| |
|
| +! n a_addr -- core plus_store |
+! ( n a_addr -- ) core plus_store |
| |
""Add @i{n} to the cell at @i{a-addr}."" |
| *a_addr += n; |
*a_addr += n; |
| : |
: |
| tuck @ + swap ! ; |
tuck @ + swap ! ; |
| |
|
| c@ c_addr -- c core cfetch |
c@ ( c_addr -- c ) core c_fetch |
| |
""@i{c} is the char stored at @i{c_addr}."" |
| c = *c_addr; |
c = *c_addr; |
| : |
: |
| [ bigendian [IF] ] |
[ bigendian [IF] ] |
| ; |
; |
| : 8>> 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ ; |
: 8>> 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ ; |
| |
|
| c! c c_addr -- core cstore |
c! ( c c_addr -- ) core c_store |
| |
""Store @i{c} into the char at @i{c-addr}."" |
| *c_addr = c; |
*c_addr = c; |
| : |
: |
| [ bigendian [IF] ] |
[ bigendian [IF] ] |
| [THEN] |
[THEN] |
| : 8<< 2* 2* 2* 2* 2* 2* 2* 2* ; |
: 8<< 2* 2* 2* 2* 2* 2* 2* 2* ; |
| |
|
| 2! w1 w2 a_addr -- core two_store |
2! ( w1 w2 a_addr -- ) core two_store |
| |
""Store @i{w2} into the cell at @i{c-addr} and @i{w1} into the next cell."" |
| a_addr[0] = w2; |
a_addr[0] = w2; |
| a_addr[1] = w1; |
a_addr[1] = w1; |
| : |
: |
| tuck ! cell+ ! ; |
tuck ! cell+ ! ; |
| |
|
| 2@ a_addr -- w1 w2 core two_fetch |
2@ ( a_addr -- w1 w2 ) core two_fetch |
| |
""@i{w2} is the content of the cell stored at @i{a-addr}, @i{w1} is |
| |
the content of the next cell."" |
| w2 = a_addr[0]; |
w2 = a_addr[0]; |
| w1 = a_addr[1]; |
w1 = a_addr[1]; |
| : |
: |
| dup cell+ @ swap @ ; |
dup cell+ @ swap @ ; |
| |
|
| cell+ a_addr1 -- a_addr2 core cell_plus |
cell+ ( a_addr1 -- a_addr2 ) core cell_plus |
| |
""@code{1 cells +}"" |
| a_addr2 = a_addr1+1; |
a_addr2 = a_addr1+1; |
| : |
: |
| cell + ; |
cell + ; |
| |
|
| cells n1 -- n2 core |
cells ( n1 -- n2 ) core |
| |
"" @i{n2} is the number of address units of @i{n1} cells."" |
| n2 = n1 * sizeof(Cell); |
n2 = n1 * sizeof(Cell); |
| : |
: |
| [ cell |
[ cell |
| 2/ dup [IF] ] 2* [ [THEN] |
2/ dup [IF] ] 2* [ [THEN] |
| drop ] ; |
drop ] ; |
| |
|
| char+ c_addr1 -- c_addr2 core care_plus |
char+ ( c_addr1 -- c_addr2 ) core char_plus |
| |
""@code{1 chars +}."" |
| c_addr2 = c_addr1 + 1; |
c_addr2 = c_addr1 + 1; |
| : |
: |
| 1+ ; |
1+ ; |
| |
|
| (chars) n1 -- n2 gforth paren_cares |
(chars) ( n1 -- n2 ) gforth paren_chars |
| n2 = n1 * sizeof(Char); |
n2 = n1 * sizeof(Char); |
| : |
: |
| ; |
; |
| |
|
| count c_addr1 -- c_addr2 u core |
count ( c_addr1 -- c_addr2 u ) core |
| |
""@i{c-addr2} is the first character and @i{u} the length of the |
| |
counted string at @i{c-addr1}."" |
| u = *c_addr1; |
u = *c_addr1; |
| c_addr2 = c_addr1+1; |
c_addr2 = c_addr1+1; |
| : |
: |
| dup 1+ swap c@ ; |
dup 1+ swap c@ ; |
| |
|
| (f83find) c_addr u f83name1 -- f83name2 new paren_f83find |
\g compiler |
| for (; f83name1 != NULL; f83name1 = f83name1->next) |
|
| |
\+f83headerstring |
| |
|
| |
(f83find) ( c_addr u f83name1 -- f83name2 ) new paren_f83find |
| |
for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next)) |
| if ((UCell)F83NAME_COUNT(f83name1)==u && |
if ((UCell)F83NAME_COUNT(f83name1)==u && |
| memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */) |
memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */) |
| break; |
break; |
| f83name2=f83name1; |
f83name2=f83name1; |
| |
#ifdef DEBUG |
| |
fprintf(stderr, "F83find "); |
| |
fwrite(c_addr, u, 1, stderr); |
| |
fprintf(stderr, " found %08x\n", f83name2); |
| |
#endif |
| : |
: |
| BEGIN dup WHILE (find-samelen) dup WHILE |
BEGIN dup WHILE (find-samelen) dup WHILE |
| >r 2dup r@ cell+ char+ capscomp 0= |
>r 2dup r@ cell+ char+ capscomp 0= |
| REPEAT THEN nip nip ; |
REPEAT THEN nip nip ; |
| : (find-samelen) ( u f83name1 -- u f83name2/0 ) |
: (find-samelen) ( u f83name1 -- u f83name2/0 ) |
| BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ; |
BEGIN 2dup cell+ c@ $1F and <> WHILE @ dup 0= UNTIL THEN ; |
| |
: capscomp ( c_addr1 u c_addr2 -- n ) |
| |
swap bounds |
| |
?DO dup c@ I c@ <> |
| |
IF dup c@ toupper I c@ toupper = |
| |
ELSE true THEN WHILE 1+ LOOP drop 0 |
| |
ELSE c@ toupper I c@ toupper - unloop THEN sgn ; |
| |
: sgn ( n -- -1/0/1 ) |
| |
dup 0= IF EXIT THEN 0< 2* 1+ ; |
| |
|
| \+has-hash [IF] |
\- |
| |
|
| (hashfind) c_addr u a_addr -- f83name2 new paren_hashfind |
(listlfind) ( c_addr u longname1 -- longname2 ) new paren_listlfind |
| F83Name *f83name1; |
longname2=listlfind(c_addr, u, longname1); |
| f83name2=NULL; |
: |
| while(a_addr != NULL) |
BEGIN dup WHILE (findl-samelen) dup WHILE |
| { |
>r 2dup r@ cell+ cell+ capscomp 0= |
| f83name1=(F83Name *)(a_addr[1]); |
IF 2drop r> EXIT THEN |
| a_addr=(Cell *)(a_addr[0]); |
r> @ |
| if ((UCell)F83NAME_COUNT(f83name1)==u && |
REPEAT THEN nip nip ; |
| memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */) |
: (findl-samelen) ( u longname1 -- u longname2/0 ) |
| { |
BEGIN 2dup cell+ @ lcount-mask and <> WHILE @ dup 0= UNTIL THEN ; |
| f83name2=f83name1; |
: capscomp ( c_addr1 u c_addr2 -- n ) |
| break; |
swap bounds |
| } |
?DO dup c@ I c@ <> |
| } |
IF dup c@ toupper I c@ toupper = |
| |
ELSE true THEN WHILE 1+ LOOP drop 0 |
| |
ELSE c@ toupper I c@ toupper - unloop THEN sgn ; |
| |
: sgn ( n -- -1/0/1 ) |
| |
dup 0= IF EXIT THEN 0< 2* 1+ ; |
| |
|
| |
\+hash |
| |
|
| |
(hashlfind) ( c_addr u a_addr -- longname2 ) new paren_hashlfind |
| |
longname2 = hashlfind(c_addr, u, a_addr); |
| : |
: |
| BEGIN dup WHILE |
BEGIN dup WHILE |
| 2@ >r >r dup r@ cell+ c@ $1F and = |
2@ >r >r dup r@ cell+ @ lcount-mask and = |
| IF 2dup r@ cell+ char+ capscomp 0= |
IF 2dup r@ cell+ cell+ capscomp 0= |
| IF 2drop r> rdrop EXIT THEN THEN |
IF 2drop r> rdrop EXIT THEN THEN |
| rdrop r> |
rdrop r> |
| REPEAT nip nip ; |
REPEAT nip nip ; |
| |
|
| (tablefind) c_addr u a_addr -- f83name2 new paren_tablefind |
(tablelfind) ( c_addr u a_addr -- longname2 ) new paren_tablelfind |
| ""A case-sensitive variant of @code{(hashfind)}"" |
""A case-sensitive variant of @code{(hashfind)}"" |
| F83Name *f83name1; |
longname2 = tablelfind(c_addr, u, a_addr); |
| f83name2=NULL; |
|
| while(a_addr != NULL) |
|
| { |
|
| f83name1=(F83Name *)(a_addr[1]); |
|
| a_addr=(Cell *)(a_addr[0]); |
|
| if ((UCell)F83NAME_COUNT(f83name1)==u && |
|
| memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */) |
|
| { |
|
| f83name2=f83name1; |
|
| break; |
|
| } |
|
| } |
|
| : |
: |
| BEGIN dup WHILE |
BEGIN dup WHILE |
| 2@ >r >r dup r@ cell+ c@ $1F and = |
2@ >r >r dup r@ cell+ @ lcount-mask and = |
| IF 2dup r@ cell+ char+ -text 0= |
IF 2dup r@ cell+ cell+ -text 0= |
| IF 2drop r> rdrop EXIT THEN THEN |
IF 2drop r> rdrop EXIT THEN THEN |
| rdrop r> |
rdrop r> |
| REPEAT nip nip ; |
REPEAT nip nip ; |
| |
: -text ( c_addr1 u c_addr2 -- n ) |
| |
swap bounds |
| |
?DO dup c@ I c@ = WHILE 1+ LOOP drop 0 |
| |
ELSE c@ I c@ - unloop THEN sgn ; |
| |
: sgn ( n -- -1/0/1 ) |
| |
dup 0= IF EXIT THEN 0< 2* 1+ ; |
| |
|
| (hashkey) c_addr u1 -- u2 gforth paren_hashkey |
(hashkey1) ( c_addr u ubits -- ukey ) gforth paren_hashkey1 |
| u2=0; |
|
| while(u1--) |
|
| u2+=(Cell)toupper(*c_addr++); |
|
| : |
|
| 0 -rot bounds ?DO I c@ toupper + LOOP ; |
|
| |
|
| (hashkey1) c_addr u ubits -- ukey gforth paren_hashkey1 |
|
| ""ukey is the hash key for the string c_addr u fitting in ubits bits"" |
""ukey is the hash key for the string c_addr u fitting in ubits bits"" |
| /* this hash function rotates the key at every step by rot bits within |
ukey = hashkey1(c_addr, u, ubits); |
| ubits bits and xors it with the character. This function does ok in |
|
| the chi-sqare-test. Rot should be <=7 (preferably <=5) for |
|
| ASCII strings (larger if ubits is large), and should share no |
|
| divisors with ubits. |
|
| */ |
|
| unsigned rot = ((char []){5,0,1,2,3,4,5,5,5,5,3,5,5,5,5,7,5,5,5,5,7,5,5,5,5,6,5,5,5,5,7,5,5})[ubits]; |
|
| Char *cp = c_addr; |
|
| for (ukey=0; cp<c_addr+u; cp++) |
|
| ukey = ((((ukey<<rot) | (ukey>>(ubits-rot))) |
|
| ^ toupper(*cp)) |
|
| & ((1<<ubits)-1)); |
|
| : |
: |
| dup rot-values + c@ over 1 swap lshift 1- >r |
dup rot-values + c@ over 1 swap lshift 1- >r |
| tuck - 2swap r> 0 2swap bounds |
tuck - 2swap r> 0 2swap bounds |
| 7 c, 5 c, 5 c, 5 c, 5 c, 6 c, 5 c, 5 c, 5 c, 5 c, |
7 c, 5 c, 5 c, 5 c, 5 c, 6 c, 5 c, 5 c, 5 c, 5 c, |
| 7 c, 5 c, 5 c, |
7 c, 5 c, 5 c, |
| |
|
| \+[THEN] |
\+ |
| |
|
| (parse-white) c_addr1 u1 -- c_addr2 u2 gforth paren_parse_white |
\+ |
| /* use !isgraph instead of isspace? */ |
|
| Char *endp = c_addr1+u1; |
(parse-white) ( c_addr1 u1 -- c_addr2 u2 ) gforth paren_parse_white |
| while (c_addr1<endp && isspace(*c_addr1)) |
struct Cellpair r=parse_white(c_addr1, u1); |
| c_addr1++; |
c_addr2 = (Char *)(r.n1); |
| if (c_addr1<endp) { |
u2 = r.n2; |
| for (c_addr2 = c_addr1; c_addr1<endp && !isspace(*c_addr1); c_addr1++) |
|
| ; |
|
| u2 = c_addr1-c_addr2; |
|
| } |
|
| else { |
|
| c_addr2 = c_addr1; |
|
| u2 = 0; |
|
| } |
|
| : |
: |
| BEGIN dup WHILE over c@ bl <= WHILE 1 /string |
BEGIN dup WHILE over c@ bl <= WHILE 1 /string |
| REPEAT THEN 2dup |
REPEAT THEN 2dup |
| BEGIN dup WHILE over c@ bl > WHILE 1 /string |
BEGIN dup WHILE over c@ bl > WHILE 1 /string |
| REPEAT THEN nip - ; |
REPEAT THEN nip - ; |
| |
|
| aligned c_addr -- a_addr core |
aligned ( c_addr -- a_addr ) core |
| |
"" @i{a-addr} is the first aligned address greater than or equal to @i{c-addr}."" |
| a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell))); |
a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell))); |
| : |
: |
| [ cell 1- ] Literal + [ -1 cells ] Literal and ; |
[ cell 1- ] Literal + [ -1 cells ] Literal and ; |
| |
|
| faligned c_addr -- f_addr float f_aligned |
faligned ( c_addr -- f_addr ) float f_aligned |
| |
"" @i{f-addr} is the first float-aligned address greater than or equal to @i{c-addr}."" |
| f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float))); |
f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float))); |
| : |
: |
| [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; |
[ 1 floats 1- ] Literal + [ -1 floats ] Literal and ; |
| |
|
| >body xt -- a_addr core to_body |
\ threading stuff is currently only interesting if we have a compiler |
| a_addr = PFA(xt); |
\fhas? standardthreading has? compiler and [IF] |
| : |
threading-method ( -- n ) gforth threading_method |
| 2 cells + ; |
|
| |
|
| >code-address xt -- c_addr gforth to_code_address |
|
| ""c_addr is the code address of the word xt"" |
|
| /* !! This behaves installation-dependently for DOES-words */ |
|
| c_addr = (Address)CODE_ADDRESS(xt); |
|
| : |
|
| @ ; |
|
| |
|
| >does-code xt -- a_addr gforth to_does_code |
|
| ""If xt ist the execution token of a defining-word-defined word, |
|
| a_addr is the start of the Forth code after the DOES>; |
|
| Otherwise a_addr is 0."" |
|
| a_addr = (Cell *)DOES_CODE(xt); |
|
| : |
|
| cell+ @ ; |
|
| |
|
| code-address! c_addr xt -- gforth code_address_store |
|
| ""Creates a code field with code address c_addr at xt"" |
|
| MAKE_CF(xt, c_addr); |
|
| CACHE_FLUSH(xt,PFA(0)); |
|
| : |
|
| ! ; |
|
| |
|
| does-code! a_addr xt -- gforth does_code_store |
|
| ""creates a code field at xt for a defining-word-defined word; a_addr |
|
| is the start of the Forth code after DOES>"" |
|
| MAKE_DOES_CF(xt, a_addr); |
|
| CACHE_FLUSH(xt,PFA(0)); |
|
| : |
|
| dodoes: over ! cell+ ! ; |
|
| |
|
| does-handler! a_addr -- gforth does_handler_store |
|
| ""creates a DOES>-handler at address a_addr. a_addr usually points |
|
| just behind a DOES>."" |
|
| MAKE_DOES_HANDLER(a_addr); |
|
| CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE); |
|
| : |
|
| drop ; |
|
| |
|
| /does-handler -- n gforth slash_does_handler |
|
| ""the size of a does-handler (includes possible padding)"" |
|
| /* !! a constant or environmental query might be better */ |
|
| n = DOES_HANDLER_SIZE; |
|
| : |
|
| 2 cells ; |
|
| |
|
| threading-method -- n gforth threading_method |
|
| ""0 if the engine is direct threaded. Note that this may change during |
""0 if the engine is direct threaded. Note that this may change during |
| the lifetime of an image."" |
the lifetime of an image."" |
| #if defined(DOUBLY_INDIRECT) |
#if defined(DOUBLY_INDIRECT) |
| : |
: |
| 1 ; |
1 ; |
| |
|
| \+has-os [IF] |
\f[THEN] |
| |
|
| |
\g hostos |
| |
|
| (key) -- n gforth paren_key |
key-file ( wfileid -- c ) gforth paren_key_file |
| |
""Read one character @i{c} from @i{wfileid}. This word disables |
| |
buffering for @i{wfileid}. If you want to read characters from a |
| |
terminal in non-canonical (raw) mode, you have to put the terminal in |
| |
non-canonical mode yourself (using the C interface); the exception is |
| |
@code{stdin}: Gforth automatically puts it into non-canonical mode."" |
| |
#ifdef HAS_FILE |
| fflush(stdout); |
fflush(stdout); |
| /* !! noecho */ |
c = key((FILE*)wfileid); |
| n = key(); |
#else |
| |
c = key(stdin); |
| |
#endif |
| |
|
| key? -- n facility key_q |
key?-file ( wfileid -- f ) gforth key_q_file |
| |
""@i{f} is true if at least one character can be read from @i{wfileid} |
| |
without blocking. If you also want to use @code{read-file} or |
| |
@code{read-line} on the file, you have to call @code{key?-file} or |
| |
@code{key-file} first (these two words disable buffering)."" |
| |
#ifdef HAS_FILE |
| fflush(stdout); |
fflush(stdout); |
| n = key_query; |
f = key_query((FILE*)wfileid); |
| |
#else |
| |
f = key_query(stdin); |
| |
#endif |
| |
|
| |
stdin ( -- wfileid ) gforth |
| |
""The standard input file of the Gforth process."" |
| |
wfileid = (Cell)stdin; |
| |
|
| stdout -- wfileid gforth |
stdout ( -- wfileid ) gforth |
| |
""The standard output file of the Gforth process."" |
| wfileid = (Cell)stdout; |
wfileid = (Cell)stdout; |
| |
|
| stderr -- wfileid gforth |
stderr ( -- wfileid ) gforth |
| |
""The standard error output file of the Gforth process."" |
| wfileid = (Cell)stderr; |
wfileid = (Cell)stderr; |
| |
|
| form -- urows ucols gforth |
\+os |
| ""The number of lines and columns in the terminal. These numbers may change |
|
| with the window size."" |
form ( -- urows ucols ) gforth |
| |
""The number of lines and columns in the terminal. These numbers may |
| |
change with the window size. Note that it depends on the OS whether |
| |
this reflects the actual size and changes with the window size |
| |
(currently only on Unix-like OSs). On other OSs you just get a |
| |
default, and can tell Gforth the terminal size by setting the |
| |
environment variables @code{COLUMNS} and @code{LINES} before starting |
| |
Gforth."" |
| /* we could block SIGWINCH here to get a consistent size, but I don't |
/* we could block SIGWINCH here to get a consistent size, but I don't |
| think this is necessary or always beneficial */ |
think this is necessary or always beneficial */ |
| urows=rows; |
urows=rows; |
| ucols=cols; |
ucols=cols; |
| |
|
| flush-icache c_addr u -- gforth flush_icache |
wcwidth ( u -- n ) gforth |
| |
""The number of fixed-width characters per unicode character u"" |
| |
#ifdef HAVE_WCWIDTH |
| |
n = wcwidth(u); |
| |
#else |
| |
n = 1; |
| |
#endif |
| |
|
| |
flush-icache ( c_addr u -- ) gforth flush_icache |
| ""Make sure that the instruction cache of the processor (if there is |
""Make sure that the instruction cache of the processor (if there is |
| one) does not contain stale data at @var{c_addr} and @var{u} bytes |
one) does not contain stale data at @i{c-addr} and @i{u} bytes |
| afterwards. @code{END-CODE} performs a @code{flush-icache} |
afterwards. @code{END-CODE} performs a @code{flush-icache} |
| automatically. Caveat: @code{flush-icache} might not work on your |
automatically. Caveat: @code{flush-icache} might not work on your |
| installation; this is usually the case if direct threading is not |
installation; this is usually the case if direct threading is not |
| your machine has a separate instruction cache. In such cases, |
your machine has a separate instruction cache. In such cases, |
| @code{flush-icache} does nothing instead of flushing the instruction |
@code{flush-icache} does nothing instead of flushing the instruction |
| cache."" |
cache."" |
| FLUSH_ICACHE(c_addr,u); |
FLUSH_ICACHE((caddr_t)c_addr,u); |
| |
|
| (bye) n -- gforth paren_bye |
(bye) ( n -- ) gforth paren_bye |
| |
SUPER_END; |
| return (Label *)n; |
return (Label *)n; |
| |
|
| (system) c_addr u -- wretval wior gforth peren_system |
(system) ( c_addr u -- wretval wior ) gforth paren_system |
| int old_tp=terminal_prepped; |
wretval = gforth_system(c_addr, u); |
| deprep_terminal(); |
|
| wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */ |
|
| wior = IOR(wretval==-1 || (wretval==127 && errno != 0)); |
wior = IOR(wretval==-1 || (wretval==127 && errno != 0)); |
| if (old_tp) |
|
| prep_terminal(); |
|
| |
|
| getenv c_addr1 u1 -- c_addr2 u2 gforth |
getenv ( c_addr1 u1 -- c_addr2 u2 ) gforth |
| c_addr2 = getenv(cstr(c_addr1,u1,1)); |
""The string @i{c-addr1 u1} specifies an environment variable. The string @i{c-addr2 u2} |
| u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2)); |
is the host operating system's expansion of that environment variable. If the |
| |
environment variable does not exist, @i{c-addr2 u2} specifies a string 0 characters |
| |
in length."" |
| |
/* close ' to keep fontify happy */ |
| |
c_addr2 = (Char *)getenv(cstr(c_addr1,u1,1)); |
| |
u2 = (c_addr2 == NULL ? 0 : strlen((char *)c_addr2)); |
| |
|
| open-pipe c_addr u ntype -- wfileid wior gforth open_pipe |
open-pipe ( c_addr u wfam -- wfileid wior ) gforth open_pipe |
| wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[ntype]); /* ~ expansion of 1st arg? */ |
fflush(stdout); |
| |
wfileid=(Cell)popen(cstr(c_addr,u,1),pfileattr[wfam]); /* ~ expansion of 1st arg? */ |
| wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */ |
wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */ |
| |
|
| close-pipe wfileid -- wretval wior gforth close_pipe |
close-pipe ( wfileid -- wretval wior ) gforth close_pipe |
| wretval = pclose((FILE *)wfileid); |
wretval = pclose((FILE *)wfileid); |
| wior = IOR(wretval==-1); |
wior = IOR(wretval==-1); |
| |
|
| time&date -- nsec nmin nhour nday nmonth nyear facility-ext time_and_date |
time&date ( -- nsec nmin nhour nday nmonth nyear ) facility-ext time_and_date |
| |
""Report the current time of day. Seconds, minutes and hours are numbered from 0. |
| |
Months are numbered from 1."" |
| |
#if 1 |
| |
time_t now; |
| |
struct tm *ltime; |
| |
time(&now); |
| |
ltime=localtime(&now); |
| |
#else |
| struct timeval time1; |
struct timeval time1; |
| struct timezone zone1; |
struct timezone zone1; |
| struct tm *ltime; |
struct tm *ltime; |
| gettimeofday(&time1,&zone1); |
gettimeofday(&time1,&zone1); |
| |
/* !! Single Unix specification: |
| |
If tzp is not a null pointer, the behaviour is unspecified. */ |
| ltime=localtime((time_t *)&time1.tv_sec); |
ltime=localtime((time_t *)&time1.tv_sec); |
| |
#endif |
| nyear =ltime->tm_year+1900; |
nyear =ltime->tm_year+1900; |
| nmonth=ltime->tm_mon+1; |
nmonth=ltime->tm_mon+1; |
| nday =ltime->tm_mday; |
nday =ltime->tm_mday; |
| nmin =ltime->tm_min; |
nmin =ltime->tm_min; |
| nsec =ltime->tm_sec; |
nsec =ltime->tm_sec; |
| |
|
| ms n -- facility-ext |
ms ( u -- ) facility-ext |
| struct timeval timeout; |
""Wait at least @i{n} milli-second."" |
| timeout.tv_sec=n/1000; |
gforth_ms(u); |
| timeout.tv_usec=1000*(n%1000); |
|
| (void)select(0,0,0,0,&timeout); |
allocate ( u -- a_addr wior ) memory |
| |
""Allocate @i{u} address units of contiguous data space. The initial |
| allocate u -- a_addr wior memory |
contents of the data space is undefined. If the allocation is successful, |
| |
@i{a-addr} is the start address of the allocated region and @i{wior} |
| |
is 0. If the allocation fails, @i{a-addr} is undefined and @i{wior} |
| |
is a non-zero I/O result code."" |
| a_addr = (Cell *)malloc(u?u:1); |
a_addr = (Cell *)malloc(u?u:1); |
| wior = IOR(a_addr==NULL); |
wior = IOR(a_addr==NULL); |
| |
|
| free a_addr -- wior memory |
free ( a_addr -- wior ) memory |
| |
""Return the region of data space starting at @i{a-addr} to the system. |
| |
The region must originally have been obtained using @code{allocate} or |
| |
@code{resize}. If the operational is successful, @i{wior} is 0. |
| |
If the operation fails, @i{wior} is a non-zero I/O result code."" |
| free(a_addr); |
free(a_addr); |
| wior = 0; |
wior = 0; |
| |
|
| resize a_addr1 u -- a_addr2 wior memory |
resize ( a_addr1 u -- a_addr2 wior ) memory |
| ""Change the size of the allocated area at @i{a_addr1} to @i{u} |
""Change the size of the allocated area at @i{a-addr1} to @i{u} |
| address units, possibly moving the contents to a different |
address units, possibly moving the contents to a different |
| area. @i{a_addr2} is the address of the resulting area. If |
area. @i{a-addr2} is the address of the resulting area. |
| @code{a_addr1} is 0, Gforth's (but not the standard) @code{resize} |
If the operation is successful, @i{wior} is 0. |
| @code{allocate}s @i{u} address units."" |
If the operation fails, @i{wior} is a non-zero |
| |
I/O result code. If @i{a-addr1} is 0, Gforth's (but not the Standard) |
| |
@code{resize} @code{allocate}s @i{u} address units."" |
| /* the following check is not necessary on most OSs, but it is needed |
/* the following check is not necessary on most OSs, but it is needed |
| on SunOS 4.1.2. */ |
on SunOS 4.1.2. */ |
| |
/* close ' to keep fontify happy */ |
| if (a_addr1==NULL) |
if (a_addr1==NULL) |
| a_addr2 = (Cell *)malloc(u); |
a_addr2 = (Cell *)malloc(u); |
| else |
else |
| a_addr2 = (Cell *)realloc(a_addr1, u); |
a_addr2 = (Cell *)realloc(a_addr1, u); |
| wior = IOR(a_addr2==NULL); /* !! Define a return code */ |
wior = IOR(a_addr2==NULL); /* !! Define a return code */ |
| |
if (a_addr2==NULL) |
| |
a_addr2 = a_addr1; |
| |
|
| strerror n -- c_addr u gforth |
strerror ( n -- c_addr u ) gforth |
| c_addr = strerror(n); |
c_addr = (Char *)strerror(n); |
| u = strlen(c_addr); |
u = strlen((char *)c_addr); |
| |
|
| |
strsignal ( n -- c_addr u ) gforth |
| |
c_addr = (Char *)strsignal(n); |
| |
u = strlen((char *)c_addr); |
| |
|
| strsignal n -- c_addr u gforth |
call-c ( ... w -- ... ) gforth call_c |
| c_addr = strsignal(n); |
|
| u = strlen(c_addr); |
|
| |
|
| call-c w -- gforth call_c |
|
| ""Call the C function pointed to by @i{w}. The C function has to |
""Call the C function pointed to by @i{w}. The C function has to |
| access the stack itself. The stack pointers are exported in the global |
access the stack itself. The stack pointers are exported in the global |
| variables @code{SP} and @code{FP}."" |
variables @code{gforth_SP} and @code{gforth_FP}."" |
| /* This is a first attempt at support for calls to C. This may change in |
/* This is a first attempt at support for calls to C. This may change in |
| the future */ |
the future */ |
| IF_FTOS(fp[0]=FTOS); |
IF_fpTOS(fp[0]=fpTOS); |
| FP=fp; |
gforth_FP=fp; |
| SP=sp; |
gforth_SP=sp; |
| |
gforth_RP=rp; |
| |
gforth_LP=lp; |
| |
#ifdef HAS_LINKBACK |
| ((void (*)())w)(); |
((void (*)())w)(); |
| sp=SP; |
#else |
| fp=FP; |
((void (*)(void *))w)(gforth_pointers); |
| IF_TOS(TOS=sp[0]); |
#endif |
| IF_FTOS(FTOS=fp[0]); |
sp=gforth_SP; |
| |
fp=gforth_FP; |
| |
rp=gforth_RP; |
| |
lp=gforth_LP; |
| |
IF_fpTOS(fpTOS=fp[0]); |
| |
|
| \+[THEN] ( has-os ) has-files [IF] |
\+ |
| |
\+file |
| |
|
| close-file wfileid -- wior file close_file |
close-file ( wfileid -- wior ) file close_file |
| wior = IOR(fclose((FILE *)wfileid)==EOF); |
wior = IOR(fclose((FILE *)wfileid)==EOF); |
| |
|
| open-file c_addr u ntype -- w2 wior file open_file |
open-file ( c_addr u wfam -- wfileid wior ) file open_file |
| w2 = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]); |
wfileid = opencreate_file(tilde_cstr(c_addr,u,1), wfam, 0, &wior); |
| wior = IOR(w2 == 0); |
|
| |
create-file ( c_addr u wfam -- wfileid wior ) file create_file |
| create-file c_addr u ntype -- w2 wior file create_file |
wfileid = opencreate_file(tilde_cstr(c_addr,u,1), wfam, O_CREAT|O_TRUNC, &wior); |
| Cell fd; |
|
| fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[ntype], 0666); |
|
| if (fd != -1) { |
|
| w2 = (Cell)fdopen(fd, fileattr[ntype]); |
|
| wior = IOR(w2 == 0); |
|
| } else { |
|
| w2 = 0; |
|
| wior = IOR(1); |
|
| } |
|
| |
|
| delete-file c_addr u -- wior file delete_file |
delete-file ( c_addr u -- wior ) file delete_file |
| wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1); |
wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1); |
| |
|
| rename-file c_addr1 u1 c_addr2 u2 -- wior file-ext rename_file |
rename-file ( c_addr1 u1 c_addr2 u2 -- wior ) file-ext rename_file |
| char *s1=tilde_cstr(c_addr2, u2, 1); |
""Rename file @i{c_addr1 u1} to new name @i{c_addr2 u2}"" |
| wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1); |
wior = rename_file(c_addr1, u1, c_addr2, u2); |
| |
|
| file-position wfileid -- ud wior file file_position |
file-position ( wfileid -- ud wior ) file file_position |
| /* !! use tell and lseek? */ |
/* !! use tell and lseek? */ |
| ud = LONG2UD(ftell((FILE *)wfileid)); |
ud = OFF2UD(ftello((FILE *)wfileid)); |
| wior = IOR(UD2LONG(ud)==-1); |
wior = IOR(UD2OFF(ud)==-1); |
| |
|
| reposition-file ud wfileid -- wior file reposition_file |
reposition-file ( ud wfileid -- wior ) file reposition_file |
| wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1); |
wior = IOR(fseeko((FILE *)wfileid, UD2OFF(ud), SEEK_SET)==-1); |
| |
|
| file-size wfileid -- ud wior file file_size |
file-size ( wfileid -- ud wior ) file file_size |
| #include <sys/stat.h> |
|
| struct stat buf; |
struct stat buf; |
| wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1); |
wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1); |
| ud = LONG2UD(buf.st_size); |
ud = OFF2UD(buf.st_size); |
| |
|
| resize-file ud wfileid -- wior file resize_file |
resize-file ( ud wfileid -- wior ) file resize_file |
| wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2LONG(ud))==-1); |
wior = IOR(ftruncate(fileno((FILE *)wfileid), UD2OFF(ud))==-1); |
| |
|
| read-file c_addr u1 wfileid -- u2 wior file read_file |
read-file ( c_addr u1 wfileid -- u2 wior ) file read_file |
| /* !! fread does not guarantee enough */ |
/* !! fread does not guarantee enough */ |
| u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid); |
u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid); |
| |
if (u2>0) |
| |
gf_regetc((FILE *)wfileid); |
| wior = FILEIO(u2<u1 && ferror((FILE *)wfileid)); |
wior = FILEIO(u2<u1 && ferror((FILE *)wfileid)); |
| /* !! is the value of ferror errno-compatible? */ |
/* !! is the value of ferror errno-compatible? */ |
| if (wior) |
if (wior) |
| clearerr((FILE *)wfileid); |
clearerr((FILE *)wfileid); |
| |
|
| read-line c_addr u1 wfileid -- u2 flag wior file read_line |
(read-line) ( c_addr u1 wfileid -- u2 flag u3 wior ) file paren_read_line |
| /* |
struct Cellquad r = read_line(c_addr, u1, (FILE *)wfileid); |
| Cell c; |
u2 = r.n1; |
| flag=-1; |
flag = r.n2; |
| for(u2=0; u2<u1; u2++) |
u3 = r.n3; |
| { |
wior = r.n4; |
| *c_addr++ = (Char)(c = getc((FILE *)wfileid)); |
|
| if(c=='\n') break; |
|
| if(c==EOF) |
|
| { |
|
| flag=FLAG(u2!=0); |
|
| break; |
|
| } |
|
| } |
|
| wior=FILEIO(ferror((FILE *)wfileid)); |
|
| */ |
|
| if ((flag=FLAG(!feof((FILE *)wfileid) && |
|
| fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) { |
|
| wior=FILEIO(ferror((FILE *)wfileid)); /* !! ior? */ |
|
| if (wior) |
|
| clearerr((FILE *)wfileid); |
|
| u2 = strlen(c_addr); |
|
| u2-=((u2>0) && (c_addr[u2-1]==NEWLINE)); |
|
| } |
|
| else { |
|
| wior=0; |
|
| u2=0; |
|
| } |
|
| |
|
| \+[THEN] has-files [IF] -1 [ELSE] has-os [THEN] [IF] |
\+ |
| |
|
| write-file c_addr u1 wfileid -- wior file write_file |
write-file ( c_addr u1 wfileid -- wior ) file write_file |
| /* !! fwrite does not guarantee enough */ |
/* !! fwrite does not guarantee enough */ |
| |
#ifdef HAS_FILE |
| { |
{ |
| UCell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid); |
UCell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid); |
| wior = FILEIO(u2<u1 && ferror((FILE *)wfileid)); |
wior = FILEIO(u2<u1 && ferror((FILE *)wfileid)); |
| if (wior) |
if (wior) |
| clearerr((FILE *)wfileid); |
clearerr((FILE *)wfileid); |
| } |
} |
| |
#else |
| |
TYPE(c_addr, u1); |
| |
#endif |
| |
|
| emit-file c wfileid -- wior gforth emit_file |
emit-file ( c wfileid -- wior ) gforth emit_file |
| |
#ifdef HAS_FILE |
| wior = FILEIO(putc(c, (FILE *)wfileid)==EOF); |
wior = FILEIO(putc(c, (FILE *)wfileid)==EOF); |
| if (wior) |
if (wior) |
| clearerr((FILE *)wfileid); |
clearerr((FILE *)wfileid); |
| |
#else |
| |
PUTC(c); |
| |
#endif |
| |
|
| \+[THEN] has-files [IF] |
\+file |
| |
|
| flush-file wfileid -- wior file-ext flush_file |
flush-file ( wfileid -- wior ) file-ext flush_file |
| wior = IOR(fflush((FILE *) wfileid)==EOF); |
wior = IOR(fflush((FILE *) wfileid)==EOF); |
| |
|
| file-status c_addr u -- ntype wior file-ext file_status |
file-status ( c_addr u -- wfam wior ) file-ext file_status |
| char *filename=tilde_cstr(c_addr, u, 1); |
struct Cellpair r = file_status(c_addr, u); |
| if (access (filename, F_OK) != 0) { |
wfam = r.n1; |
| ntype=0; |
wior = r.n2; |
| wior=IOR(1); |
|
| } |
file-eof? ( wfileid -- flag ) gforth file_eof_query |
| else if (access (filename, R_OK | W_OK) == 0) { |
flag = FLAG(feof((FILE *) wfileid)); |
| ntype=2; /* r/w */ |
|
| wior=0; |
open-dir ( c_addr u -- wdirid wior ) gforth open_dir |
| } |
""Open the directory specified by @i{c-addr, u} |
| else if (access (filename, R_OK) == 0) { |
and return @i{dir-id} for futher access to it."" |
| ntype=0; /* r/o */ |
wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1)); |
| |
wior = IOR(wdirid == 0); |
| |
|
| |
read-dir ( c_addr u1 wdirid -- u2 flag wior ) gforth read_dir |
| |
""Attempt to read the next entry from the directory specified |
| |
by @i{dir-id} to the buffer of length @i{u1} at address @i{c-addr}. |
| |
If the attempt fails because there is no more entries, |
| |
@i{ior}=0, @i{flag}=0, @i{u2}=0, and the buffer is unmodified. |
| |
If the attempt to read the next entry fails because of any other reason, |
| |
return @i{ior}<>0. |
| |
If the attempt succeeds, store file name to the buffer at @i{c-addr} |
| |
and return @i{ior}=0, @i{flag}=true and @i{u2} equal to the size of the file name. |
| |
If the length of the file name is greater than @i{u1}, |
| |
store first @i{u1} characters from file name into the buffer and |
| |
indicate "name too long" with @i{ior}, @i{flag}=true, and @i{u2}=@i{u1}."" |
| |
struct dirent * dent; |
| |
dent = readdir((DIR *)wdirid); |
| wior=0; |
wior=0; |
| |
flag = -1; |
| |
if(dent == NULL) { |
| |
u2 = 0; |
| |
flag = 0; |
| |
} else { |
| |
u2 = strlen((char *)dent->d_name); |
| |
if(u2 > u1) { |
| |
u2 = u1; |
| |
wior = -512-ENAMETOOLONG; |
| } |
} |
| else if (access (filename, W_OK) == 0) { |
memmove(c_addr, dent->d_name, u2); |
| ntype=4; /* w/o */ |
|
| wior=0; |
|
| } |
} |
| else { |
|
| ntype=1; /* well, we cannot access the file, but better deliver a legal |
close-dir ( wdirid -- wior ) gforth close_dir |
| access mode (r/o bin), so we get a decent error later upon open. */ |
""Close the directory specified by @i{dir-id}."" |
| wior=0; |
wior = IOR(closedir((DIR *)wdirid)); |
| |
|
| |
filename-match ( c_addr1 u1 c_addr2 u2 -- flag ) gforth match_file |
| |
char * string = cstr(c_addr1, u1, 1); |
| |
char * pattern = cstr(c_addr2, u2, 0); |
| |
flag = FLAG(!fnmatch(pattern, string, 0)); |
| |
|
| |
set-dir ( c_addr u -- wior ) gforth set_dir |
| |
""Change the current directory to @i{c-addr, u}. |
| |
Return an error if this is not possible"" |
| |
wior = IOR(chdir(tilde_cstr(c_addr, u, 1))); |
| |
|
| |
get-dir ( c_addr1 u1 -- c_addr2 u2 ) gforth get_dir |
| |
""Store the current directory in the buffer specified by @i{c-addr1, u1}. |
| |
If the buffer size is not sufficient, return 0 0"" |
| |
c_addr2 = (Char *)getcwd((char *)c_addr1, u1); |
| |
if(c_addr2 != NULL) { |
| |
u2 = strlen((char *)c_addr2); |
| |
} else { |
| |
u2 = 0; |
| } |
} |
| |
|
| \+[THEN] ( has-files ) has-floats [IF] |
=mkdir ( c_addr u wmode -- wior ) gforth equals_mkdir |
| |
""Create directory @i{c-addr u} with mode @i{wmode}."" |
| |
wior = IOR(mkdir(tilde_cstr(c_addr,u,1),wmode)); |
| |
|
| |
\+ |
| |
|
| |
newline ( -- c_addr u ) gforth |
| |
""String containing the newline sequence of the host OS"" |
| |
char newline[] = { |
| |
#if DIRSEP=='/' |
| |
/* Unix */ |
| |
'\n' |
| |
#else |
| |
/* DOS, Win, OS/2 */ |
| |
'\r','\n' |
| |
#endif |
| |
}; |
| |
c_addr=(Char *)newline; |
| |
u=sizeof(newline); |
| |
: |
| |
"newline count ; |
| |
Create "newline e? crlf [IF] 2 c, $0D c, [ELSE] 1 c, [THEN] $0A c, |
| |
|
| |
\+os |
| |
|
| |
utime ( -- dtime ) gforth |
| |
""Report the current time in microseconds since some epoch."" |
| |
struct timeval time1; |
| |
gettimeofday(&time1,NULL); |
| |
dtime = timeval2us(&time1); |
| |
|
| |
cputime ( -- duser dsystem ) gforth |
| |
""duser and dsystem are the respective user- and system-level CPU |
| |
times used since the start of the Forth system (excluding child |
| |
processes), in microseconds (the granularity may be much larger, |
| |
however). On platforms without the getrusage call, it reports elapsed |
| |
time (since some epoch) for duser and 0 for dsystem."" |
| |
#ifdef HAVE_GETRUSAGE |
| |
struct rusage usage; |
| |
getrusage(RUSAGE_SELF, &usage); |
| |
duser = timeval2us(&usage.ru_utime); |
| |
dsystem = timeval2us(&usage.ru_stime); |
| |
#else |
| |
struct timeval time1; |
| |
gettimeofday(&time1,NULL); |
| |
duser = timeval2us(&time1); |
| |
dsystem = DZERO; |
| |
#endif |
| |
|
| |
ntime ( -- dtime ) gforth |
| |
""Report the current time in nanoseconds since some epoch."" |
| |
struct timespec time1; |
| |
#ifdef HAVE_CLOCK_GETTIME |
| |
clock_gettime(CLOCK_REALTIME,&time1); |
| |
#else |
| |
struct timeval time2; |
| |
gettimeofday(&time2,NULL); |
| |
time1.tv_sec = time2.tv_sec;1 |
| |
time1.tv_nsec = time2.tv_usec*1000; |
| |
#endif |
| |
dtime = timespec2ns(&time1); |
| |
|
| |
\+ |
| |
|
| |
\+floating |
| |
|
| |
\g floating |
| |
|
| comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth) |
comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth) |
| comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth) |
comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth) |
| |
|
| d>f d -- r float d_to_f |
s>f ( n -- r ) float s_to_f |
| #ifdef BUGGY_LONG_LONG |
r = n; |
| |
|
| |
d>f ( d -- r ) float d_to_f |
| |
#ifdef BUGGY_LL_D2F |
| extern double ldexp(double x, int exp); |
extern double ldexp(double x, int exp); |
| r = ldexp((Float)d.hi,CELL_BITS) + (Float)d.lo; |
if (DHI(d)<0) { |
| |
#ifdef BUGGY_LL_ADD |
| |
DCell d2=dnegate(d); |
| |
#else |
| |
DCell d2=-d; |
| |
#endif |
| |
r = -(ldexp((Float)DHI(d2),CELL_BITS) + (Float)DLO(d2)); |
| |
} else |
| |
r = ldexp((Float)DHI(d),CELL_BITS) + (Float)DLO(d); |
| #else |
#else |
| r = d; |
r = d; |
| #endif |
#endif |
| |
|
| f>d r -- d float f_to_d |
f>d ( r -- d ) float f_to_d |
| #ifdef BUGGY_LONG_LONG |
extern DCell double2ll(Float r); |
| d.hi = ldexp(r,-CELL_BITS) - (r<0); |
d = double2ll(r); |
| d.lo = r-ldexp((Float)d.hi,CELL_BITS); |
|
| #else |
|
| d = r; |
|
| #endif |
|
| |
|
| f! r f_addr -- float f_store |
f>s ( r -- n ) float f_to_s |
| |
n = (Cell)r; |
| |
|
| |
f! ( r f_addr -- ) float f_store |
| |
""Store @i{r} into the float at address @i{f-addr}."" |
| *f_addr = r; |
*f_addr = r; |
| |
|
| f@ f_addr -- r float f_fetch |
f@ ( f_addr -- r ) float f_fetch |
| |
""@i{r} is the float at address @i{f-addr}."" |
| r = *f_addr; |
r = *f_addr; |
| |
|
| df@ df_addr -- r float-ext d_f_fetch |
df@ ( df_addr -- r ) float-ext d_f_fetch |
| |
""Fetch the double-precision IEEE floating-point value @i{r} from the address @i{df-addr}."" |
| #ifdef IEEE_FP |
#ifdef IEEE_FP |
| r = *df_addr; |
r = *df_addr; |
| #else |
#else |
| !! df@ |
!! df@ |
| #endif |
#endif |
| |
|
| df! r df_addr -- float-ext d_f_store |
df! ( r df_addr -- ) float-ext d_f_store |
| |
""Store @i{r} as double-precision IEEE floating-point value to the |
| |
address @i{df-addr}."" |
| #ifdef IEEE_FP |
#ifdef IEEE_FP |
| *df_addr = r; |
*df_addr = r; |
| #else |
#else |
| !! df! |
!! df! |
| #endif |
#endif |
| |
|
| sf@ sf_addr -- r float-ext s_f_fetch |
sf@ ( sf_addr -- r ) float-ext s_f_fetch |
| |
""Fetch the single-precision IEEE floating-point value @i{r} from the address @i{sf-addr}."" |
| #ifdef IEEE_FP |
#ifdef IEEE_FP |
| r = *sf_addr; |
r = *sf_addr; |
| #else |
#else |
| !! sf@ |
!! sf@ |
| #endif |
#endif |
| |
|
| sf! r sf_addr -- float-ext s_f_store |
sf! ( r sf_addr -- ) float-ext s_f_store |
| |
""Store @i{r} as single-precision IEEE floating-point value to the |
| |
address @i{sf-addr}."" |
| #ifdef IEEE_FP |
#ifdef IEEE_FP |
| *sf_addr = r; |
*sf_addr = r; |
| #else |
#else |
| !! sf! |
!! sf! |
| #endif |
#endif |
| |
|
| f+ r1 r2 -- r3 float f_plus |
f+ ( r1 r2 -- r3 ) float f_plus |
| r3 = r1+r2; |
r3 = r1+r2; |
| |
|
| f- r1 r2 -- r3 float f_minus |
f- ( r1 r2 -- r3 ) float f_minus |
| r3 = r1-r2; |
r3 = r1-r2; |
| |
|
| f* r1 r2 -- r3 float f_star |
f* ( r1 r2 -- r3 ) float f_star |
| r3 = r1*r2; |
r3 = r1*r2; |
| |
|
| f/ r1 r2 -- r3 float f_slash |
f/ ( r1 r2 -- r3 ) float f_slash |
| r3 = r1/r2; |
r3 = r1/r2; |
| |
|
| f** r1 r2 -- r3 float-ext f_star_star |
f** ( r1 r2 -- r3 ) float-ext f_star_star |
| ""@i{r3} is @i{r1} raised to the @i{r2}th power"" |
""@i{r3} is @i{r1} raised to the @i{r2}th power."" |
| |
CLOBBER_TOS_WORKAROUND_START; |
| r3 = pow(r1,r2); |
r3 = pow(r1,r2); |
| |
CLOBBER_TOS_WORKAROUND_END; |
| |
|
| |
fm* ( r1 n -- r2 ) gforth fm_star |
| |
r2 = r1*n; |
| |
|
| |
fm/ ( r1 n -- r2 ) gforth fm_slash |
| |
r2 = r1/n; |
| |
|
| fnegate r1 -- r2 float |
fm*/ ( r1 n1 n2 -- r2 ) gforth fm_star_slash |
| |
r2 = (r1*n1)/n2; |
| |
|
| |
f**2 ( r1 -- r2 ) gforth fm_square |
| |
r2 = r1*r1; |
| |
|
| |
fnegate ( r1 -- r2 ) float f_negate |
| r2 = - r1; |
r2 = - r1; |
| |
|
| fdrop r -- float |
fdrop ( r -- ) float f_drop |
| |
|
| fdup r -- r r float |
fdup ( r -- r r ) float f_dupe |
| |
|
| fswap r1 r2 -- r2 r1 float |
fswap ( r1 r2 -- r2 r1 ) float f_swap |
| |
|
| fover r1 r2 -- r1 r2 r1 float |
fover ( r1 r2 -- r1 r2 r1 ) float f_over |
| |
|
| frot r1 r2 r3 -- r2 r3 r1 float |
frot ( r1 r2 r3 -- r2 r3 r1 ) float f_rote |
| |
|
| fnip r1 r2 -- r2 gforth |
fnip ( r1 r2 -- r2 ) gforth f_nip |
| |
|
| ftuck r1 r2 -- r2 r1 r2 gforth |
ftuck ( r1 r2 -- r2 r1 r2 ) gforth f_tuck |
| |
|
| float+ f_addr1 -- f_addr2 float float_plus |
float+ ( f_addr1 -- f_addr2 ) float float_plus |
| |
""@code{1 floats +}."" |
| f_addr2 = f_addr1+1; |
f_addr2 = f_addr1+1; |
| |
|
| floats n1 -- n2 float |
floats ( n1 -- n2 ) float |
| |
""@i{n2} is the number of address units of @i{n1} floats."" |
| n2 = n1*sizeof(Float); |
n2 = n1*sizeof(Float); |
| |
|
| floor r1 -- r2 float |
floor ( r1 -- r2 ) float |
| ""round towards the next smaller integral value, i.e., round toward negative infinity"" |
""Round towards the next smaller integral value, i.e., round toward negative infinity."" |
| /* !! unclear wording */ |
/* !! unclear wording */ |
| |
CLOBBER_TOS_WORKAROUND_START; |
| r2 = floor(r1); |
r2 = floor(r1); |
| |
CLOBBER_TOS_WORKAROUND_END; |
| |
|
| fround r1 -- r2 float |
fround ( r1 -- r2 ) float f_round |
| ""round to the nearest integral value"" |
""Round to the nearest integral value."" |
| /* !! unclear wording */ |
|
| #ifdef HAVE_RINT |
|
| r2 = rint(r1); |
r2 = rint(r1); |
| #else |
|
| r2 = floor(r1+0.5); |
|
| /* !! This is not quite true to the rounding rules given in the standard */ |
|
| #endif |
|
| |
|
| fmax r1 r2 -- r3 float |
fmax ( r1 r2 -- r3 ) float f_max |
| if (r1<r2) |
if (r1<r2) |
| r3 = r2; |
r3 = r2; |
| else |
else |
| r3 = r1; |
r3 = r1; |
| |
|
| fmin r1 r2 -- r3 float |
fmin ( r1 r2 -- r3 ) float f_min |
| if (r1<r2) |
if (r1<r2) |
| r3 = r1; |
r3 = r1; |
| else |
else |
| r3 = r2; |
r3 = r2; |
| |
|
| represent r c_addr u -- n f1 f2 float |
represent ( r c_addr u -- n f1 f2 ) float |
| char *sig; |
char *sig; |
| |
size_t siglen; |
| int flag; |
int flag; |
| int decpt; |
int decpt; |
| sig=ecvt(r, u, &decpt, &flag); |
sig=ecvt(r, u, &decpt, &flag); |
| n=(r==0 ? 1 : decpt); |
n=(r==0. ? 1 : decpt); |
| |
flag=signbit(r); /* not all ecvt()s do this as desired */ |
| f1=FLAG(flag!=0); |
f1=FLAG(flag!=0); |
| f2=FLAG(isdigit(sig[0])!=0); |
f2=FLAG(isdigit((unsigned)(sig[0]))!=0); |
| memmove(c_addr,sig,u); |
siglen=strlen((char *)sig); |
| |
if (siglen>u) /* happens in glibc-2.1.3 if 999.. is rounded up */ |
| |
siglen=u; |
| |
if (!f2) /* workaround Cygwin trailing 0s for Inf and Nan */ |
| |
for (; sig[siglen-1]=='0'; siglen--); |
| |
; |
| |
memcpy(c_addr,sig,siglen); |
| |
memset(c_addr+siglen,f2?'0':' ',u-siglen); |
| |
|
| >float c_addr u -- flag float to_float |
>float ( c_addr u -- f:... flag ) float to_float |
| /* real signature: c_addr u -- r t / f */ |
""Actual stack effect: ( c_addr u -- r t | f ). Attempt to convert the |
| |
character string @i{c-addr u} to internal floating-point |
| |
representation. If the string represents a valid floating-point number |
| |
@i{r} is placed on the floating-point stack and @i{flag} is |
| |
true. Otherwise, @i{flag} is false. A string of blanks is a special |
| |
case and represents the floating-point number 0."" |
| Float r; |
Float r; |
| char *number=cstr(c_addr, u, 1); |
flag = to_float(c_addr, u, &r); |
| char *endconv; |
if (flag) { |
| while(isspace(number[--u]) && u>0); |
fp--; |
| switch(number[u]) |
fp[0]=r; |
| { |
|
| case 'd': |
|
| case 'D': |
|
| case 'e': |
|
| case 'E': break; |
|
| default : u++; break; |
|
| } |
|
| number[u]='\0'; |
|
| r=strtod(number,&endconv); |
|
| if((flag=FLAG(!(Cell)*endconv))) |
|
| { |
|
| IF_FTOS(fp[0] = FTOS); |
|
| fp += -1; |
|
| FTOS = r; |
|
| } |
|
| else if(*endconv=='d' || *endconv=='D') |
|
| { |
|
| *endconv='E'; |
|
| r=strtod(number,&endconv); |
|
| if((flag=FLAG(!(Cell)*endconv))) |
|
| { |
|
| IF_FTOS(fp[0] = FTOS); |
|
| fp += -1; |
|
| FTOS = r; |
|
| } |
|
| } |
} |
| |
|
| fabs r1 -- r2 float-ext |
fabs ( r1 -- r2 ) float-ext f_abs |
| r2 = fabs(r1); |
r2 = fabs(r1); |
| |
|
| facos r1 -- r2 float-ext |
facos ( r1 -- r2 ) float-ext f_a_cos |
| |
CLOBBER_TOS_WORKAROUND_START; |
| r2 = acos(r1); |
r2 = acos(r1); |
| |
CLOBBER_TOS_WORKAROUND_END; |
| |
|
| fasin r1 -- r2 float-ext |
fasin ( r1 -- r2 ) float-ext f_a_sine |
| |
CLOBBER_TOS_WORKAROUND_START; |
| r2 = asin(r1); |
r2 = asin(r1); |
| |
CLOBBER_TOS_WORKAROUND_END; |
| |
|
| fatan r1 -- r2 float-ext |
fatan ( r1 -- r2 ) float-ext f_a_tan |
| r2 = atan(r1); |
r2 = atan(r1); |
| |
|
| fatan2 r1 r2 -- r3 float-ext |
fatan2 ( r1 r2 -- r3 ) float-ext f_a_tan_two |
| ""@i{r1/r2}=tan@i{r3}. The standard does not require, but probably |
""@i{r1/r2}=tan(@i{r3}). ANS Forth does not require, but probably |
| intends this to be the inverse of @code{fsincos}. In gforth it is."" |
intends this to be the inverse of @code{fsincos}. In gforth it is."" |
| |
CLOBBER_TOS_WORKAROUND_START; |
| r3 = atan2(r1,r2); |
r3 = atan2(r1,r2); |
| |
CLOBBER_TOS_WORKAROUND_END; |
| |
|
| fcos r1 -- r2 float-ext |
fcos ( r1 -- r2 ) float-ext f_cos |
| |
CLOBBER_TOS_WORKAROUND_START; |
| r2 = cos(r1); |
r2 = cos(r1); |
| |
CLOBBER_TOS_WORKAROUND_END; |
| |
|
| fexp r1 -- r2 float-ext |
fexp ( r1 -- r2 ) float-ext f_e_x_p |
| |
CLOBBER_TOS_WORKAROUND_START; |
| r2 = exp(r1); |
r2 = exp(r1); |
| |
CLOBBER_TOS_WORKAROUND_END; |
| |
|
| fexpm1 r1 -- r2 float-ext |
fexpm1 ( r1 -- r2 ) float-ext f_e_x_p_m_one |
| ""@i{r2}=@i{e}**@i{r1}@minus{}1"" |
""@i{r2}=@i{e}**@i{r1}@minus{}1"" |
| #ifdef HAVE_EXPM1 |
#ifdef HAVE_EXPM1 |
| extern double expm1(double); |
extern double |
| |
#ifdef NeXT |
| |
const |
| |
#endif |
| |
expm1(double); |
| |
CLOBBER_TOS_WORKAROUND_START; |
| r2 = expm1(r1); |
r2 = expm1(r1); |
| |
CLOBBER_TOS_WORKAROUND_END; |
| #else |
#else |
| |
CLOBBER_TOS_WORKAROUND_START; |
| r2 = exp(r1)-1.; |
r2 = exp(r1)-1.; |
| |
CLOBBER_TOS_WORKAROUND_END; |
| #endif |
#endif |
| |
|
| fln r1 -- r2 float-ext |
fln ( r1 -- r2 ) float-ext f_l_n |
| |
CLOBBER_TOS_WORKAROUND_START; |
| r2 = log(r1); |
r2 = log(r1); |
| |
CLOBBER_TOS_WORKAROUND_END; |
| |
|
| flnp1 r1 -- r2 float-ext |
flnp1 ( r1 -- r2 ) float-ext f_l_n_p_one |
| ""@i{r2}=ln(@i{r1}+1)"" |
""@i{r2}=ln(@i{r1}+1)"" |
| #ifdef HAVE_LOG1P |
#ifdef HAVE_LOG1P |
| extern double log1p(double); |
extern double |
| |
#ifdef NeXT |
| |
const |
| |
#endif |
| |
log1p(double); |
| r2 = log1p(r1); |
r2 = log1p(r1); |
| #else |
#else |
| r2 = log(r1+1.); |
r2 = log(r1+1.); |
| #endif |
#endif |
| |
|
| flog r1 -- r2 float-ext |
flog ( r1 -- r2 ) float-ext f_log |
| ""the decimal logarithm"" |
""The decimal logarithm."" |
| |
CLOBBER_TOS_WORKAROUND_START; |
| r2 = log10(r1); |
r2 = log10(r1); |
| |
CLOBBER_TOS_WORKAROUND_END; |
| |
|
| falog r1 -- r2 float-ext |
falog ( r1 -- r2 ) float-ext f_a_log |
| ""@i{r2}=10**@i{r1}"" |
""@i{r2}=10**@i{r1}"" |
| extern double pow10(double); |
extern double pow10(double); |
| |
CLOBBER_TOS_WORKAROUND_START; |
| r2 = pow10(r1); |
r2 = pow10(r1); |
| |
CLOBBER_TOS_WORKAROUND_END; |
| |
|
| fsin r1 -- r2 float-ext |
fsin ( r1 -- r2 ) float-ext f_sine |
| |
CLOBBER_TOS_WORKAROUND_START; |
| r2 = sin(r1); |
r2 = sin(r1); |
| |
CLOBBER_TOS_WORKAROUND_END; |
| |
|
| fsincos r1 -- r2 r3 float-ext |
fsincos ( r1 -- r2 r3 ) float-ext f_sine_cos |
| ""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})"" |
""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})"" |
| |
CLOBBER_TOS_WORKAROUND_START; |
| r2 = sin(r1); |
r2 = sin(r1); |
| r3 = cos(r1); |
r3 = cos(r1); |
| |
CLOBBER_TOS_WORKAROUND_END; |
| |
|
| fsqrt r1 -- r2 float-ext |
fsqrt ( r1 -- r2 ) float-ext f_square_root |
| r2 = sqrt(r1); |
r2 = sqrt(r1); |
| |
|
| ftan r1 -- r2 float-ext |
ftan ( r1 -- r2 ) float-ext f_tan |
| |
CLOBBER_TOS_WORKAROUND_START; |
| r2 = tan(r1); |
r2 = tan(r1); |
| |
CLOBBER_TOS_WORKAROUND_END; |
| : |
: |
| fsincos f/ ; |
fsincos f/ ; |
| |
|
| fsinh r1 -- r2 float-ext |
fsinh ( r1 -- r2 ) float-ext f_cinch |
| |
CLOBBER_TOS_WORKAROUND_START; |
| r2 = sinh(r1); |
r2 = sinh(r1); |
| |
CLOBBER_TOS_WORKAROUND_END; |
| : |
: |
| fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ; |
fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ; |
| |
|
| fcosh r1 -- r2 float-ext |
fcosh ( r1 -- r2 ) float-ext f_cosh |
| |
CLOBBER_TOS_WORKAROUND_START; |
| r2 = cosh(r1); |
r2 = cosh(r1); |
| |
CLOBBER_TOS_WORKAROUND_END; |
| : |
: |
| fexp fdup 1/f f+ f2/ ; |
fexp fdup 1/f f+ f2/ ; |
| |
|
| ftanh r1 -- r2 float-ext |
ftanh ( r1 -- r2 ) float-ext f_tan_h |
| |
CLOBBER_TOS_WORKAROUND_START; |
| r2 = tanh(r1); |
r2 = tanh(r1); |
| |
CLOBBER_TOS_WORKAROUND_END; |
| : |
: |
| f2* fexpm1 fdup 2. d>f f+ f/ ; |
f2* fexpm1 fdup 2. d>f f+ f/ ; |
| |
|
| fasinh r1 -- r2 float-ext |
fasinh ( r1 -- r2 ) float-ext f_a_cinch |
| |
CLOBBER_TOS_WORKAROUND_START; |
| r2 = asinh(r1); |
r2 = asinh(r1); |
| |
CLOBBER_TOS_WORKAROUND_END; |
| : |
: |
| fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ; |
fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ; |
| |
|
| facosh r1 -- r2 float-ext |
facosh ( r1 -- r2 ) float-ext f_a_cosh |
| |
CLOBBER_TOS_WORKAROUND_START; |
| r2 = acosh(r1); |
r2 = acosh(r1); |
| |
CLOBBER_TOS_WORKAROUND_END; |
| : |
: |
| fdup fdup f* 1. d>f f- fsqrt f+ fln ; |
fdup fdup f* 1. d>f f- fsqrt f+ fln ; |
| |
|
| fatanh r1 -- r2 float-ext |
fatanh ( r1 -- r2 ) float-ext f_a_tan_h |
| |
CLOBBER_TOS_WORKAROUND_START; |
| r2 = atanh(r1); |
r2 = atanh(r1); |
| |
CLOBBER_TOS_WORKAROUND_END; |
| : |
: |
| fdup f0< >r fabs 1. d>f fover f- f/ f2* flnp1 f2/ |
fdup f0< >r fabs 1. d>f fover f- f/ f2* flnp1 f2/ |
| r> IF fnegate THEN ; |
r> IF fnegate THEN ; |
| |
|
| sfloats n1 -- n2 float-ext s_floats |
sfloats ( n1 -- n2 ) float-ext s_floats |
| |
""@i{n2} is the number of address units of @i{n1} |
| |
single-precision IEEE floating-point numbers."" |
| n2 = n1*sizeof(SFloat); |
n2 = n1*sizeof(SFloat); |
| |
|
| dfloats n1 -- n2 float-ext d_floats |
dfloats ( n1 -- n2 ) float-ext d_floats |
| |
""@i{n2} is the number of address units of @i{n1} |
| |
double-precision IEEE floating-point numbers."" |
| n2 = n1*sizeof(DFloat); |
n2 = n1*sizeof(DFloat); |
| |
|
| sfaligned c_addr -- sf_addr float-ext s_f_aligned |
sfaligned ( c_addr -- sf_addr ) float-ext s_f_aligned |
| |
""@i{sf-addr} is the first single-float-aligned address greater |
| |
than or equal to @i{c-addr}."" |
| sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat))); |
sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat))); |
| : |
: |
| [ 1 sfloats 1- ] Literal + [ -1 sfloats ] Literal and ; |
[ 1 sfloats 1- ] Literal + [ -1 sfloats ] Literal and ; |
| |
|
| dfaligned c_addr -- df_addr float-ext d_f_aligned |
dfaligned ( c_addr -- df_addr ) float-ext d_f_aligned |
| |
""@i{df-addr} is the first double-float-aligned address greater |
| |
than or equal to @i{c-addr}."" |
| df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&(-sizeof(DFloat))); |
df_addr = (DFloat *)((((Cell)c_addr)+(sizeof(DFloat)-1))&(-sizeof(DFloat))); |
| : |
: |
| [ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ; |
[ 1 dfloats 1- ] Literal + [ -1 dfloats ] Literal and ; |
| |
|
| |
v* ( f_addr1 nstride1 f_addr2 nstride2 ucount -- r ) gforth v_star |
| |
""dot-product: r=v1*v2. The first element of v1 is at f_addr1, the |
| |
next at f_addr1+nstride1 and so on (similar for v2). Both vectors have |
| |
ucount elements."" |
| |
r = v_star(f_addr1, nstride1, f_addr2, nstride2, ucount); |
| |
: |
| |
>r swap 2swap swap 0e r> 0 ?DO |
| |
dup f@ over + 2swap dup f@ f* f+ over + 2swap |
| |
LOOP 2drop 2drop ; |
| |
|
| |
faxpy ( ra f_x nstridex f_y nstridey ucount -- ) gforth |
| |
""vy=ra*vx+vy"" |
| |
faxpy(ra, f_x, nstridex, f_y, nstridey, ucount); |
| |
: |
| |
>r swap 2swap swap r> 0 ?DO |
| |
fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap |
| |
LOOP 2drop 2drop fdrop ; |
| |
|
| |
\+ |
| |
|
| \ The following words access machine/OS/installation-dependent |
\ The following words access machine/OS/installation-dependent |
| \ Gforth internals |
\ Gforth internals |
| \ !! how about environmental queries DIRECT-THREADED, |
\ !! how about environmental queries DIRECT-THREADED, |
| \ INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */ |
\ INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */ |
| |
|
| \ local variable implementation primitives |
\ local variable implementation primitives |
| \+[THEN] ( has-floats ) has-locals [IF] |
|
| |
|
| @local# -- w gforth fetch_local_number |
\+glocals |
| w = *(Cell *)(lp+(Cell)NEXT_INST); |
|
| INC_IP(1); |
|
| |
|
| @local0 -- w new fetch_local_zero |
\g locals |
| w = *(Cell *)(lp+0*sizeof(Cell)); |
|
| |
|
| @local1 -- w new fetch_local_four |
@local# ( #noffset -- w ) gforth fetch_local_number |
| w = *(Cell *)(lp+1*sizeof(Cell)); |
w = *(Cell *)(lp+noffset); |
| |
|
| @local2 -- w new fetch_local_eight |
@local0 ( -- w ) new fetch_local_zero |
| w = *(Cell *)(lp+2*sizeof(Cell)); |
w = ((Cell *)lp)[0]; |
| |
|
| @local3 -- w new fetch_local_twelve |
@local1 ( -- w ) new fetch_local_four |
| w = *(Cell *)(lp+3*sizeof(Cell)); |
w = ((Cell *)lp)[1]; |
| |
|
| \+has-floats [IF] |
@local2 ( -- w ) new fetch_local_eight |
| |
w = ((Cell *)lp)[2]; |
| |
|
| f@local# -- r gforth f_fetch_local_number |
@local3 ( -- w ) new fetch_local_twelve |
| r = *(Float *)(lp+(Cell)NEXT_INST); |
w = ((Cell *)lp)[3]; |
| INC_IP(1); |
|
| |
|
| f@local0 -- r new f_fetch_local_zero |
\+floating |
| r = *(Float *)(lp+0*sizeof(Float)); |
|
| |
|
| f@local1 -- r new f_fetch_local_eight |
f@local# ( #noffset -- r ) gforth f_fetch_local_number |
| r = *(Float *)(lp+1*sizeof(Float)); |
r = *(Float *)(lp+noffset); |
| |
|
| \+[THEN] |
f@local0 ( -- r ) new f_fetch_local_zero |
| |
r = ((Float *)lp)[0]; |
| |
|
| laddr# -- c_addr gforth laddr_number |
f@local1 ( -- r ) new f_fetch_local_eight |
| |
r = ((Float *)lp)[1]; |
| |
|
| |
\+ |
| |
|
| |
laddr# ( #noffset -- c_addr ) gforth laddr_number |
| /* this can also be used to implement lp@ */ |
/* this can also be used to implement lp@ */ |
| c_addr = (Char *)(lp+(Cell)NEXT_INST); |
c_addr = (Char *)(lp+noffset); |
| INC_IP(1); |
|
| |
|
| lp+!# -- gforth lp_plus_store_number |
lp+!# ( #noffset -- ) gforth lp_plus_store_number |
| ""used with negative immediate values it allocates memory on the |
""used with negative immediate values it allocates memory on the |
| local stack, a positive immediate argument drops memory from the local |
local stack, a positive immediate argument drops memory from the local |
| stack"" |
stack"" |
| lp += (Cell)NEXT_INST; |
lp += noffset; |
| INC_IP(1); |
|
| |
|
| lp- -- new minus_four_lp_plus_store |
lp- ( -- ) new minus_four_lp_plus_store |
| lp += -sizeof(Cell); |
lp += -sizeof(Cell); |
| |
|
| lp+ -- new eight_lp_plus_store |
lp+ ( -- ) new eight_lp_plus_store |
| lp += sizeof(Float); |
lp += sizeof(Float); |
| |
|
| lp+2 -- new sixteen_lp_plus_store |
lp+2 ( -- ) new sixteen_lp_plus_store |
| lp += 2*sizeof(Float); |
lp += 2*sizeof(Float); |
| |
|
| lp! c_addr -- gforth lp_store |
lp! ( c_addr -- ) gforth lp_store |
| lp = (Address)c_addr; |
lp = (Address)c_addr; |
| |
|
| >l w -- gforth to_l |
>l ( w -- ) gforth to_l |
| lp -= sizeof(Cell); |
lp -= sizeof(Cell); |
| *(Cell *)lp = w; |
*(Cell *)lp = w; |
| |
|
| \+has-floats [IF] |
\+floating |
| |
|
| f>l r -- gforth f_to_l |
f>l ( r -- ) gforth f_to_l |
| lp -= sizeof(Float); |
lp -= sizeof(Float); |
| *(Float *)lp = r; |
*(Float *)lp = r; |
| |
|
| \+[THEN] [THEN] \ has-locals |
fpick ( f:... u -- f:... r ) gforth |
| |
""Actually the stack effect is @code{ r0 ... ru u -- r0 ... ru r0 }."" |
| |
r = fp[u]; |
| |
: |
| |
floats fp@ + f@ ; |
| |
|
| \+has-OS [IF] |
\+ |
| |
\+ |
| |
|
| define(`uploop', |
\+OS |
| `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')') |
|
| define(`_uploop', |
\g syslib |
| `ifelse($1, `$3', `$5', |
|
| `$4`'define(`$1', incr($1))_uploop(`$1', `$2', `$3', `$4', `$5')')') |
|
| \ argflist(argnum): Forth argument list |
|
| define(argflist, |
|
| `ifelse($1, 0, `', |
|
| `uploop(`_i', 1, $1, `format(`u%d ', _i)', `format(`u%d ', _i)')')') |
|
| \ argdlist(argnum): declare C's arguments |
|
| define(argdlist, |
|
| `ifelse($1, 0, `', |
|
| `uploop(`_i', 1, $1, `Cell, ', `Cell')')') |
|
| \ argclist(argnum): pass C's arguments |
|
| define(argclist, |
|
| `ifelse($1, 0, `', |
|
| `uploop(`_i', 1, $1, `format(`u%d, ', _i)', `format(`u%d', _i)')')') |
|
| \ icall(argnum) |
|
| define(icall, |
|
| `icall$1 argflist($1)u -- uret gforth |
|
| uret = ((Cell(*)(argdlist($1)))u)(argclist($1)); |
|
| |
|
| ') |
|
| define(fcall, |
|
| `fcall$1 argflist($1)u -- rret gforth |
|
| rret = ((Float(*)(argdlist($1)))u)(argclist($1)); |
|
| |
|
| ') |
|
| |
|
| |
|
| open-lib c_addr1 u1 -- u2 gforth open_lib |
|
| #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) |
|
| u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_LAZY); |
|
| #else |
|
| # ifdef HAVE_LIBKERNEL32 |
|
| u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1)); |
|
| # else |
|
| #warning Define open-lib! |
|
| u2 = 0; |
|
| # endif |
|
| #endif |
|
| |
|
| lib-sym c_addr1 u1 u2 -- u3 gforth lib_sym |
open-lib ( c_addr1 u1 -- u2 ) gforth open_lib |
| #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) |
u2 = gforth_dlopen(c_addr1, u1); |
| |
|
| |
lib-sym ( c_addr1 u1 u2 -- u3 ) gforth lib_sym |
| |
#ifdef HAVE_LIBLTDL |
| |
u3 = (UCell) lt_dlsym((lt_dlhandle)u2, cstr(c_addr1, u1, 1)); |
| |
#elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) |
| u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1)); |
u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1)); |
| #else |
#else |
| # ifdef HAVE_LIBKERNEL32 |
# ifdef _WIN32 |
| u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1)); |
u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1)); |
| # else |
# else |
| #warning Define lib-sym! |
#warning Define lib-sym! |
| # endif |
# endif |
| #endif |
#endif |
| |
|
| uploop(i, 0, 7, `icall(i)') |
wcall ( ... u -- ... ) gforth |
| icall(20) |
gforth_FP=fp; |
| uploop(i, 0, 7, `fcall(i)') |
sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &gforth_FP); |
| fcall(20) |
fp=gforth_FP; |
| |
|
| |
uw@ ( c_addr -- u ) gforth u_w_fetch |
| |
""@i{u} is the zero-extended 16-bit value stored at @i{c_addr}."" |
| |
u = *(UWyde*)(c_addr); |
| |
|
| |
sw@ ( c_addr -- n ) gforth s_w_fetch |
| |
""@i{n} is the sign-extended 16-bit value stored at @i{c_addr}."" |
| |
n = *(Wyde*)(c_addr); |
| |
|
| |
w! ( w c_addr -- ) gforth w_store |
| |
""Store the bottom 16 bits of @i{w} at @i{c_addr}."" |
| |
*(Wyde*)(c_addr) = w; |
| |
|
| |
ul@ ( c_addr -- u ) gforth u_l_fetch |
| |
""@i{u} is the zero-extended 32-bit value stored at @i{c_addr}."" |
| |
u = *(UTetrabyte*)(c_addr); |
| |
|
| |
sl@ ( c_addr -- n ) gforth s_l_fetch |
| |
""@i{n} is the sign-extended 32-bit value stored at @i{c_addr}."" |
| |
n = *(Tetrabyte*)(c_addr); |
| |
|
| |
l! ( w c_addr -- ) gforth l_store |
| |
""Store the bottom 32 bits of @i{w} at @i{c_addr}."" |
| |
*(Tetrabyte*)(c_addr) = w; |
| |
|
| |
lib-error ( -- c_addr u ) gforth lib_error |
| |
""Error message for last failed @code{open-lib} or @code{lib-sym}."" |
| |
#ifdef HAVE_LIBLTDL |
| |
c_addr = (Char *)lt_dlerror(); |
| |
u = (c_addr == NULL) ? 0 : strlen((char *)c_addr); |
| |
#elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN) |
| |
c_addr = dlerror(); |
| |
u = strlen(c_addr); |
| |
#else |
| |
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 = ((Cell)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 = ((Cell)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 |
| |
|
| |
\+peephole |
| |
|
| |
compile-prim1 ( a_prim -- ) gforth compile_prim1 |
| |
""compile prim (incl. immargs) at @var{a_prim}"" |
| |
compile_prim1(a_prim); |
| |
|
| |
finish-code ( ... -- ... ) gforth finish_code |
| |
""Perform delayed steps in code generation (branch resolution, I-cache |
| |
flushing)."" |
| |
/* The ... above are a workaround for a bug in gcc-2.95, which fails |
| |
to save spTOS (gforth-fast --enable-force-reg) */ |
| |
finish_code(); |
| |
|
| |
forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode |
| |
f = forget_dyncode(c_code); |
| |
|
| |
decompile-prim ( a_code -- a_prim ) gforth-internal decompile_prim |
| |
""a_prim is the code address of the primitive that has been |
| |
compile_prim1ed to a_code"" |
| |
a_prim = (Cell *)decompile_code((Label)a_code); |
| |
|
| |
\ set-next-code and call2 do not appear in images and can be |
| |
\ renumbered arbitrarily |
| |
|
| |
set-next-code ( #w -- ) gforth set_next_code |
| |
#ifdef NO_IP |
| |
next_code = (Label)w; |
| |
#endif |
| |
|
| |
call2 ( #a_callee #a_ret_addr -- R:a_ret_addr ) gforth |
| |
/* call with explicit return address */ |
| |
#ifdef NO_IP |
| |
INST_TAIL; |
| |
JUMP(a_callee); |
| |
#else |
| |
assert(0); |
| |
#endif |
| |
|
| |
tag-offsets ( -- a_addr ) gforth tag_offsets |
| |
extern Cell groups[32]; |
| |
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)); |
| |
|
| \+[THEN] \ has-OS |
|
| |
|
| up! a_addr -- gforth up_store |
\g static_super |
| UP=up=(char *)a_addr; |
|
| : |
ifdef(`STACK_CACHE_FILE', |
| up ! ; |
`include(peeprules.vmg)') |
| Variable UP |
|
| |
|
| |
\g end |
