Diff for /gforth/prim between versions 1.102 and 1.110

version 1.102, 2002/11/24 13:54:00 version 1.110, 2002/12/28 17:18:27
Line 105 Line 105
\E   \E
\E set-current  \E set-current
\E store-optimization on  \E store-optimization on
\E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump

\   \
\   \
Line 817  lshift ( u1 n -- u2 )  core l_shift Line 818  lshift ( u1 n -- u2 )  core l_shift
:  :
0 ?DO 2* LOOP ;      0 ?DO 2* LOOP ;

\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
Line 938  f = FLAG(u1-u2 < u3-u2); Line 941  f = FLAG(u1-u2 < u3-u2);
:  :
over - >r - r> u< ;   over - >r - r> u< ;

\g internal

sp@     ( -- a_addr )           gforth          sp_fetch  sp@     ( -- a_addr )           gforth          sp_fetch

Line 1090  w = sp[u+1]; Line 1091  w = sp[u+1];

\ toggle is high-level: 0.11/0.42%  \ toggle is high-level: 0.11/0.42%

\g memory

@       ( a_addr -- w )         core    fetch  @       ( a_addr -- w )         core    fetch
""@i{w} is the cell stored at @i{a_addr}.""  ""@i{w} is the cell stored at @i{a_addr}.""
:  :
dup 1+ swap c@ ;   dup 1+ swap c@ ;

\g compiler

(f83find)       ( c_addr u f83name1 -- f83name2 )       new     paren_f83find  (f83find)       ( c_addr u f83name1 -- f83name2 )       new     paren_f83find
for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))  for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))
if ((UCell)F83NAME_COUNT(f83name1)==u &&    if ((UCell)F83NAME_COUNT(f83name1)==u &&
Line 1288  while(u1--) Line 1293  while(u1--)
ASCII strings (larger if ubits is large), and should share no     ASCII strings (larger if ubits is large), and should share no
divisors with ubits.     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];  static char rot_values[] = {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};
unsigned rot = rot_values[ubits];
ukey = ((((ukey<<rot) | (ukey>>(ubits-rot)))       ukey = ((((ukey<<rot) | (ukey>>(ubits-rot)))
Line 1604  wior = IOR(rename(tilde_cstr(c_addr1, u1 Line 1610  wior = IOR(rename(tilde_cstr(c_addr1, u1

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
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);

/* !! fread does not guarantee enough */  /* !! fread does not guarantee enough */
Line 1808  floor ( r1 -- r2 ) float Line 1814  floor ( r1 -- r2 ) float
/* !! unclear wording */  /* !! unclear wording */
r2 = floor(r1);  r2 = floor(r1);

(fround)        ( r1 -- r2 )    gforth  paren_f_round  fround  ( r1 -- r2 )    gforth  f_round
""Round to the nearest integral value.  Primitive variant (unused)""  ""Round to the nearest integral value.""
/* !! eliminate this as primitive? */
/* !! 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   f_max  fmax    ( r1 r2 -- r3 ) float   f_max
if (r1<r2)  if (r1<r2)
\+  \+
\+glocals  \+glocals

\g locals

@local# ( #noffset -- w )       gforth  fetch_local_number  @local# ( #noffset -- w )       gforth  fetch_local_number
w = *(Cell *)(lp+noffset);  w = *(Cell *)(lp+noffset);

Line 2099  r = fp[u+1]; /* +1, because update of fp Line 2100  r = fp[u+1]; /* +1, because update of fp

\+OS  \+OS

\g syslib

define(`uploop',  define(`uploop',
`pushdef(`\$1', `\$2')_uploop(`\$1', `\$2', `\$3', `\$4', `\$5')`'popdef(`\$1')')         `pushdef(`\$1', `\$2')_uploop(`\$1', `\$2', `\$3', `\$4', `\$5')`'popdef(`\$1')')
define(`_uploop',  define(`_uploop',
Line 2435  SET_IP((Xt *)a_callee); Line 2438  SET_IP((Xt *)a_callee);

compile-prim ( xt1 -- xt2 )     new     compile_prim  compile-prim ( xt1 -- xt2 )     obsolete        compile_prim
xt2 = (Xt)compile_prim((Label)xt1);  xt2 = (Xt)compile_prim((Label)xt1);

\ lit@ / lit_fetch = lit @  \ lit@ / lit_fetch = lit @
Line 2461  does-exec ( #a_cfa -- R:nest a_pfa ) new Line 2464  does-exec ( #a_cfa -- R:nest a_pfa ) new
assert(0);  assert(0);
#else  #else
a_pfa = PFA(a_cfa);  a_pfa = PFA(a_cfa);
nest = (Cell)ip;  nest = (Cell)IP;
IF_spTOS(spTOS = sp[0]);  IF_spTOS(spTOS = sp[0]);
#ifdef DEBUG  #ifdef DEBUG
{      {
Line 2750  SUPER_CONTINUE; Line 2753  SUPER_CONTINUE;
cell+       cell+
THEN  >r ;   THEN  >r ;

\ set-next-code and call2 do not appear in images and can be
\ renumbered arbitrarily

set-next-code ( #w -- ) gforth set_next_code  set-next-code ( #w -- ) gforth set_next_code
#ifdef NO_IP  #ifdef NO_IP
next_code = (Label)w;  next_code = (Label)w;
Line 2773  finish-code ( -- ) gforth finish_code Line 2779  finish-code ( -- ) gforth finish_code
flushing).""  flushing).""
finish_code();  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 = decompile_code(a_code);

\+  \+

include(peeprules.vmg)  include(peeprules.vmg)

\g end

\+  \+

 Removed from v.1.102 changed lines Added in v.1.110

FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>