[gforth] / gforth / Attic / primitives

# gforth: gforth/Attic/primitives

### Diff for /gforth/Attic/primitives between version 1.17 and 1.18

version 1.17, Thu Sep 8 17:20:10 1994 UTC version 1.18, Mon Sep 12 19:00:35 1994 UTC
 Line 70
 Line 70

noop    --              fig  noop    --              fig
;  ;
:
;

lit     -- w            fig  lit     -- w            fig
w = (Cell)*ip++;  w = (Cell)*ip++;
 Line 88
 Line 90
branch  --              fig  branch  --              fig
branch:  branch:
ip = (Xt *)(((int)ip)+(int)*ip);  ip = (Xt *)(((int)ip)+(int)*ip);
:
r> dup @ + >r ;

\ condbranch(forthname,restline,code)  \ condbranch(forthname,restline,code)
\ this is non-syntactical: code must open a brace that is close by the macro  \ this is non-syntactical: code must open a brace that is close by the macro
 Line 128
 Line 132
/* 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 */
int olddiff = index-rp[1];  int olddiff = index-rp[1];
#ifndef undefined  #ifdef undefined
if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */  if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */
|| (olddiff^n)>=0          /* it is a wrap-around effect */) {      || (olddiff^n)>=0          /* it is a wrap-around effect */) {
#else  #else
#ifndef MAXINT  #ifndef MAXINT
#define MAXINT ((1<<(8*sizeof(Cell)-1))-1)  #define MAXINT ((1<<(8*sizeof(Cell)-1))-1)
#endif  #endif
if(((olddiff^MAXINT) >= n) ? ((olddiff+n) >= 0) : ((olddiff+n) < 0)) {  if(((olddiff^MAXINT) >= n) ^ ((olddiff+n) < 0)) {
#endif  #endif
#ifdef i386  #ifdef i386
*rp += n;      *rp += n;
 Line 168
 Line 172

unloop          --      core  unloop          --      core
rp += 2;  rp += 2;
:
r> rdrop rdrop >r ;

(for)   ncount --               cmFORTH         paren_for  (for)   ncount --               cmFORTH         paren_for
/* or (for) = >r -- collides with unloop! */  /* or (for) = >r -- collides with unloop! */
*--rp = 0;  *--rp = 0;
*--rp = ncount;  *--rp = ncount;
:
r> swap 0 >r >r >r ;

(do)    nlimit nstart --                fig             paren_do  (do)    nlimit nstart --                fig             paren_do
/* or do it in high-level? 0.09/0.23% */  /* or do it in high-level? 0.09/0.23% */
 Line 219
 Line 227

cr      --              fig  cr      --              fig
puts("");  puts("");
:
\$0A emit ;

move    c_from c_to ucount --           core  move    c_from c_to ucount --           core
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 ;

cmove   c_from c_to u --        string  cmove   c_from c_to u --        string
while (u-- > 0)  while (u-- > 0)
*c_to++ = *c_from++;    *c_to++ = *c_from++;
:
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)  while (u-- > 0)
c_to[u] = c_from[u];    c_to[u] = c_from[u];
:
dup 0= IF  drop 2drop exit  THEN
rot over + -rot bounds swap 1-
DO  1- dup c@ I c!  -1 +LOOP  drop ;

fill    c_addr u c --   core  fill    c_addr u c --   core
:
-rot bounds
?DO  dup I c!  LOOP  drop ;

 Line 243
 Line 264
n = -1;    n = -1;
else if (n>0)  else if (n>0)
n = 1;    n = 1;
:
rot 2dup - >r min swap -text dup
IF    rdrop
ELSE  drop r@ 0>
IF    rdrop -1
ELSE  r> 1 and
THEN
THEN ;

 Line 250
 Line 279
n = -1;    n = -1;
else if (n>0)  else if (n>0)
n = 1;    n = 1;
:
swap bounds
?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0
ELSE  c@ I c@ - unloop  THEN  -text-flag ;
: -text-flag ( n -- -1/0/1 )
dup 0< IF  drop -1  ELSE  0>  IF  1  ELSE  0  THEN  THEN  ;

Char c1, c2;  Char c1, c2;
 Line 268
 Line 303
break;      break;
}    }
}  }
:
swap bounds
?DO  dup c@ toupper I c@ toupper = WHILE  1+  LOOP  drop 0
ELSE  c@ toupper I c@ toupper - unloop  THEN  -text-flag ;

u2 = u1;  u2 = u1;
u2--;    u2--;
:
BEGIN  1- 2dup + c@ bl =  WHILE
dup  0= UNTIL  ELSE  1+  THEN ;

u2 = u1-n;  u2 = u1-n;
:
tuck - >r + r> dup 0< IF  - 0  THEN ;

+       n1 n2 -- n              core,fig        plus  +       n1 n2 -- n              core,fig        plus
n = n1+n2;  n = n1+n2;

-       n1 n2 -- n              core,fig        minus  -       n1 n2 -- n              core,fig        minus
n = n1-n2;  n = n1-n2;
:
negate + ;

negate  n1 -- n2                core,fig  negate  n1 -- n2                core,fig
/* use minus as alias */  /* use minus as alias */
n2 = -n1;  n2 = -n1;
:
invert 1+ ;

1+      n1 -- n2                core            one_plus  1+      n1 -- n2                core            one_plus
n2 = n1+1;  n2 = n1+1;
:
1 + ;

1-      n1 -- n2                core            one_minus  1-      n1 -- n2                core            one_minus
n2 = n1-1;  n2 = n1-1;
:
1 - ;

max     n1 n2 -- n      core  max     n1 n2 -- n      core
if (n1<n2)  if (n1<n2)
 Line 300
 Line 352
else  else
n = n1;    n = n1;
:  :
2dup < if   2dup < IF swap THEN drop ;
swap drop
else
drop
endif ;

min     n1 n2 -- n      core  min     n1 n2 -- n      core
if (n1<n2)  if (n1<n2)
n = n1;    n = n1;
else  else
n = n2;    n = n2;
:
2dup > IF swap THEN drop ;

abs     n1 -- n2        core  abs     n1 -- n2        core
if (n1<0)  if (n1<0)
n2 = -n1;    n2 = -n1;
else  else
n2 = n1;    n2 = n1;
:
dup 0< IF negate THEN ;

*       n1 n2 -- n              core,fig        star  *       n1 n2 -- n              core,fig        star
n = n1*n2;  n = n1*n2;
:
um* drop ;

/       n1 n2 -- n              core,fig        slash  /       n1 n2 -- n              core,fig        slash
n = n1/n2;  n = n1/n2;
:
/mod nip ;

mod     n1 n2 -- n              core  mod     n1 n2 -- n              core
n = n1%n2;  n = n1%n2;
:
/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! */
:
>r s>d r> fm/mod ;

2*      n1 -- n2                core            two_star  2*      n1 -- n2                core            two_star
n2 = 2*n1;  n2 = 2*n1;
:
dup + ;

2/      n1 -- n2                core            two_slash  2/      n1 -- n2                core            two_slash
/* !! is this still correct? */  /* !! is this still correct? */
 Line 359
 Line 421
n3++;    n3++;
n2-=n1;    n2-=n1;
}  }
:
over >r dup >r abs -rot
dabs rot um/mod
r> 0< IF       negate       THEN
r> 0< IF  swap negate swap  THEN ;

m*      n1 n2 -- d              core    m_star  m*      n1 n2 -- d              core    m_star
d = (DCell)n1 * (DCell)n2;  d = (DCell)n1 * (DCell)n2;
:
2dup      0< and >r
2dup swap 0< and >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 */
 Line 373
 Line 444

m+      d1 n -- d2              double          m_plus  m+      d1 n -- d2              double          m_plus
d2 = d1+n;  d2 = d1+n;
:
s>d d+ ;

d+      d1 d2 -- d              double,fig      d_plus  d+      d1 d2 -- d              double,fig      d_plus
d = d1+d2;  d = d1+d2;
:
>r swap >r over 2/ over 2/ + >r over 1 and over 1 and + 2/
r> + >r + r> 0< r> r> + swap - ;

d-      d1 d2 -- d              double          d_minus  d-      d1 d2 -- d              double          d_minus
d = d1-d2;  d = d1-d2;
:
dnegate d+ ;

dnegate d1 -- d2                double  dnegate d1 -- d2                double
/* use dminus as alias */  /* use dminus as alias */
d2 = -d1;  d2 = -d1;
:
invert swap negate tuck 0= - ;

dmax    d1 d2 -- d      double  dmax    d1 d2 -- d      double
if (d1<d2)  if (d1<d2)
d = d2;    d = d2;
else  else
d = d1;    d = d1;
:
2over 2over d> IF  2swap  THEN 2drop ;

dmin    d1 d2 -- d      double  dmin    d1 d2 -- d      double
if (d1<d2)  if (d1<d2)
d = d1;    d = d1;
else  else
d = d2;    d = d2;
:
2over 2over d< IF  2swap  THEN 2drop ;

dabs    d1 -- d2        double  dabs    d1 -- d2        double
if (d1<0)  if (d1<0)
d2 = -d1;    d2 = -d1;
else  else
d2 = d1;    d2 = d1;
:
dup 0< IF dnegate THEN ;

d2*     d1 -- d2                double          d_two_star  d2*     d1 -- d2                double          d_two_star
d2 = 2*d1;  d2 = 2*d1;
:
2dup d+ ;

d2/     d1 -- d2                double          d_two_slash  d2/     d1 -- d2                double          d_two_slash
/* !! is this still correct? */  /* !! is this still correct? */
d2 = d1>>1;  d2 = d1>>1;
:
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 ;

d>s     d -- n                  double          d_to_s  d>s     d -- n                  double          d_to_s
/* make this an alias for drop? */  /* make this an alias for drop? */
n = d;  n = d;
:
drop ;

and     w1 w2 -- w              core,fig  and     w1 w2 -- w              core,fig
w = w1&w2;  w = w1&w2;
 Line 424
 Line 517

invert  w1 -- w2                core  invert  w1 -- w2                core
w2 = ~w1;  w2 = ~w1;
:
-1 xor ;

rshift  u1 n -- u2              core  rshift  u1 n -- u2              core
u2 = u1>>n;    u2 = u1>>n;
 Line 463
 Line 558

within  u1 u2 u3 -- f           core-ext  within  u1 u2 u3 -- f           core-ext
f = FLAG(u1-u2 < u3-u2);  f = FLAG(u1-u2 < u3-u2);
:
over - >r - r> u< ;

 Line 529
 Line 626
rot     w1 w2 w3 -- w2 w3 w1    core    rote  rot     w1 w2 w3 -- w2 w3 w1    core    rote

-rot    w1 w2 w3 -- w3 w1 w2    fig     not_rote  -rot    w1 w2 w3 -- w3 w1 w2    fig     not_rote
:
rot rot ;

nip     w1 w2 -- w2             core-ext  nip     w1 w2 -- w2             core-ext
:
swap drop ;

tuck    w1 w2 -- w2 w1 w2       core-ext  tuck    w1 w2 -- w2 w1 w2       core-ext
:
swap over ;

?dup    w -- w                  core    question_dupe  ?dup    w -- w                  core    question_dupe
if (w!=0) {  if (w!=0) {
 Line 541
 Line 644
*--sp = w;    *--sp = w;
#endif  #endif
}  }
:
dup IF dup THEN ;

pick    u -- w                  core-ext  pick    u -- w                  core-ext
w = sp[u+1];  w = sp[u+1];
:
1+ cells sp@ + @ ;

2drop   w1 w2 --                core    two_drop  2drop   w1 w2 --                core    two_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 ;

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 ;

2swap   w1 w2 w3 w4 -- w3 w4 w1 w2      core    two_swap  2swap   w1 w2 w3 w4 -- w3 w4 w1 w2      core    two_swap
:
>r -rot r> -rot ;

2rot    w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2  double  two_rote  2rot    w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2  double  two_rote
:
>r >r 2swap r> r> 2swap ;

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

 Line 575
 Line 692
2!      w1 w2 a_addr --         core    two_store  2!      w1 w2 a_addr --         core    two_store
:
tuck ! cell+ ! ;

2@      a_addr -- w1 w2         core    two_fetch  2@      a_addr -- w1 w2         core    two_fetch
:
dup cell+ @ swap @ ;

d!      d a_addr --             double  d_store  d!      d a_addr --             double  d_store
/* !! alignment problems on some machines */  /* !! alignment problems on some machines */
 Line 589
 Line 710

:
[ cell ] Literal + ;

cells   n1 -- n2                core  cells   n1 -- n2                core
n2 = n1 * sizeof(Cell);  n2 = n1 * sizeof(Cell);
:
[ cell ]
[ 2/ dup ] [IF] 2* [THEN]
[ 2/ dup ] [IF] 2* [THEN]
[ 2/ dup ] [IF] 2* [THEN]
[ 2/ dup ] [IF] 2* [THEN]
[ drop ] ;

:
1+ ;

chars   n1 -- n2                core    cares  chars   n1 -- n2                core    cares
n2 = n1 * sizeof(Char);  n2 = n1 * sizeof(Char);
:
;

:
dup 1+ swap c@ ;

(bye)   n --    toolkit-ext     paren_bye  (bye)   n --    toolkit-ext     paren_bye
deprep_terminal();
return (Label *)n;  return (Label *)n;

system  c_addr u -- n   own  system  c_addr u -- n   own
 Line 658
 Line 793
strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)        strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
break;      break;
f83name2=f83name1;  f83name2=f83name1;
:
BEGIN  dup  WHILE
>r dup r@ cell+ c@ \$1F and =
IF  2dup r@ cell+ char+ capscomp  0=
IF  2drop r>  EXIT  THEN  THEN
r> @
REPEAT  nip nip ;

F83Name *f83name1;  F83Name *f83name1;
 Line 673
 Line 815
break;          break;
}       }
}  }
:
BEGIN  dup  WHILE
2@ >r >r dup r@ cell+ c@ \$1F and =
IF  2dup r@ cell+ char+ capscomp 0=
IF  2drop r> rdrop  EXIT  THEN  THEN
rdrop r>
REPEAT nip nip ;

(hashkey)       c_addr u1 -- u2         new     paren_hashkey  (hashkey)       c_addr u1 -- u2         new     paren_hashkey
u2=0;  u2=0;
while(u1--)  while(u1--)
:
0 -rot bounds ?DO  I c@ toupper +  LOOP ;

(hashkey1)      c_addr u ubits -- ukey          new     paren_hashkey1  (hashkey1)      c_addr u ubits -- ukey          new     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""
 Line 693
 Line 844
ukey = ((((ukey<<rot) | (ukey>>(ubits-rot)))      ukey = ((((ukey<<rot) | (ukey>>(ubits-rot)))
^ toupper(*cp))               ^ toupper(*cp))
& ((1<<ubits)-1));              & ((1<<ubits)-1));
:
dup rot-values + c@ over 1 swap lshift 1- >r
tuck - 2swap r> 0 2swap bounds
?DO  dup 4 pick lshift swap 3 pick rshift or
I c@ toupper xor
over and  LOOP
nip nip nip ;
Create rot-values
5 c, 0 c, 1 c, 2 c, 3 c,  4 c, 5 c, 5 c, 5 c, 5 c,
3 c, 5 c, 5 c, 5 c, 5 c,  7 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,

/* use !isgraph instead of isspace? */  /* use !isgraph instead of isspace? */
 Line 708
 Line 871
u2 = 0;    u2 = 0;
}  }
:
BEGIN  dup  WHILE  over c@ bl <=  WHILE  1 /string
REPEAT  THEN  2dup
BEGIN  dup  WHILE  over c@ bl >   WHILE  1 /string
REPEAT  THEN  nip - ;

close-file      wfileid -- wior file    close_file  close-file      wfileid -- wior file    close_file
wior = FILEIO(fclose((FILE *)wfileid)==EOF);  wior = FILEIO(fclose((FILE *)wfileid)==EOF);
 Line 950
 Line 1118

fexpm1          r1 -- r2        float-ext  fexpm1          r1 -- r2        float-ext
r2 =  r2 =
#ifdef expm1  #ifdef HAS_EXPM1
expm1(r1);          expm1(r1);
#else  #else
exp(r1)-1;          exp(r1)-1;
 Line 961
 Line 1129

flnp1           r1 -- r2        float-ext  flnp1           r1 -- r2        float-ext
r2 =  r2 =
#ifdef log1p  #ifdef HAS_LOG1P
log1p(r1);          log1p(r1);
#else  #else
log(r1+1);          log(r1+1);
 Line 1034
 Line 1202
w = *(Cell *)(lp+(int)(*ip++));  w = *(Cell *)(lp+(int)(*ip++));

@local0 -- w    new     fetch_local_zero  @local0 -- w    new     fetch_local_zero
w = *(Cell *)(lp+0);  w = *(Cell *)(lp+0*sizeof(Cell));

@local4 -- w    new     fetch_local_four  @local1 -- w    new     fetch_local_four
w = *(Cell *)(lp+4);  w = *(Cell *)(lp+1*sizeof(Cell));

@local8 -- w    new     fetch_local_eight  @local2 -- w    new     fetch_local_eight
w = *(Cell *)(lp+8);  w = *(Cell *)(lp+2*sizeof(Cell));

@local12        -- w    new     fetch_local_twelve  @local3 -- w    new     fetch_local_twelve
w = *(Cell *)(lp+12);  w = *(Cell *)(lp+3*sizeof(Cell));

f@local#        -- r    new     f_fetch_local_number  f@local#        -- r    new     f_fetch_local_number
r = *(Float *)(lp+(int)(*ip++));  r = *(Float *)(lp+(int)(*ip++));

f@local0        -- r    new     f_fetch_local_zero  f@local0        -- r    new     f_fetch_local_zero
r = *(Float *)(lp+0);  r = *(Float *)(lp+0*sizeof(Float));

f@local8        -- r    new     f_fetch_local_eight  f@local1        -- r    new     f_fetch_local_eight
r = *(Float *)(lp+8);  r = *(Float *)(lp+1*sizeof(Float));

/* this can also be used to implement lp@ */  /* this can also be used to implement lp@ */
 Line 1064
 Line 1232
stack""  stack""
lp += (int)(*ip++);  lp += (int)(*ip++);

-4lp+!  --      new     minus_four_lp_plus_store  lp-     --      new     minus_four_lp_plus_store
lp += -4;  lp += -sizeof(Cell);

8lp+!   --      new     eight_lp_plus_store  lp+     --      new     eight_lp_plus_store
lp += 8;  lp += sizeof(Float);

16lp+!  --      new     sixteen_lp_plus_store  lp+2    --      new     sixteen_lp_plus_store
lp += 16;  lp += 2*sizeof(Float);

 Line 1085
 Line 1253
*(Float *)lp = r;  *(Float *)lp = r;