[gforth] / gforth / Attic / primitives

# gforth: gforth/Attic/primitives

### Diff for /gforth/Attic/primitives between version 1.11 and 1.19

version 1.11, Fri Jul 8 15:00:59 1994 UTC version 1.19, Mon Sep 26 20:31:15 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 125
 Line 129
condbranch((+loop),n --         fig     paren_plus_loop,  condbranch((+loop),n --         fig     paren_plus_loop,
/* !! check this thoroughly */  /* !! check this thoroughly */
int index = *rp;  int index = *rp;
int olddiff = index-rp[1];
/* 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];
#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
#ifndef MAXINT
#define MAXINT ((1<<(8*sizeof(Cell)-1))-1)
#endif
if(((olddiff^MAXINT) >= n) ^ ((olddiff+n) < 0)) {
#endif
#ifdef i386
*rp += n;
#else
*rp = index+n;      *rp = index+n;
#endif
IF_TOS(TOS = sp[0]);      IF_TOS(TOS = sp[0]);
)  )

 Line 139
 Line 154
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 */
int oldindex = *rp;  int index = *rp;
int diff = oldindex-rp[1];  int diff = index-rp[1];
int newdiff = diff+n;  int newdiff = diff+n;
if (n<0) {  if (n<0) {
diff = -diff;      diff = -diff;
newdiff = - newdiff;      newdiff = - newdiff;
}  }
if (diff>=0 || newdiff<0) {  if (diff>=0 || newdiff<0) {
*rp = oldindex+n;  #ifdef i386
*rp += n;
#else
*rp = index + n;
#endif
IF_TOS(TOS = sp[0]);      IF_TOS(TOS = sp[0]);
)  )

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% */
*--rp = nlimit;  *--rp = nlimit;
*--rp = nstart;  *--rp = nstart;
:  :
swap >r >r ;   r> -rot swap >r >r >r ;

(?do)   nlimit nstart --        core-ext        paren_question_do  (?do)   nlimit nstart --        core-ext        paren_question_do
*--rp = nlimit;  *--rp = nlimit;
 Line 193
 Line 216
fwrite(c_addr,sizeof(Char),n,stdout);  fwrite(c_addr,sizeof(Char),n,stdout);
emitcounter += n;  emitcounter += n;

key     -- n            fig  (key)   -- n            fig     paren_key
fflush(stdout);  fflush(stdout);
/* !! noecho */  /* !! noecho */
n = key();  n = key();
 Line 204
 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
memset(c_addr,c,u);  memset(c_addr,c,u);
:
-rot bounds
?DO  dup I c!  LOOP  drop ;

compare         c_addr1 u1 c_addr2 u2 -- n      string  compare         c_addr1 u1 c_addr2 u2 -- n      string
n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);  n = memcmp(c_addr1, c_addr2, u1<u2 ? u1 : u2);
 Line 228
 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 ;

-text           c_addr1 u c_addr2 -- n  new     dash_text  -text           c_addr1 u c_addr2 -- n  new     dash_text
n = memcmp(c_addr1, c_addr2, u);  n = memcmp(c_addr1, c_addr2, u);
 Line 235
 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  ;

capscomp        c_addr1 u c_addr2 -- n  new  capscomp        c_addr1 u c_addr2 -- n  new
Char c1, c2;  Char c1, c2;
 Line 253
 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 ;

-trailing       c_addr u1 -- c_addr u2          string  dash_trailing  -trailing       c_addr u1 -- c_addr u2          string  dash_trailing
u2 = u1;  u2 = u1;
while (c_addr[u2-1] == ' ')  while (c_addr[u2-1] == ' ')
u2--;    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
c_addr2 = c_addr1+n;  c_addr2 = c_addr1+n;
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 285
 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 344
 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 355
 Line 441
um/mod  ud u1 -- u2 u3          core    u_m_slash_mod  um/mod  ud u1 -- u2 u3          core    u_m_slash_mod
u3 = ud/u1;  u3 = ud/u1;
u2 = ud%u1;  u2 = ud%u1;
:
dup IF  0 (um/mod)  THEN  nip ;
: (um/mod)  ( ud ud--ud u)
2dup >r >r  dup 0<
IF    2drop 0
ELSE  2dup d+  (um/mod)  2*  THEN
-rot  r> r> 2over 2over  du<
IF    2drop rot
ELSE  dnegate  d+  rot 1+  THEN ;

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/2;  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 409
 Line 526

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 448
 Line 567

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

sp@     -- a_addr               fig             spat  sp@     -- a_addr               fig             spat
a_addr = sp;  a_addr = sp+1;

sp!     a_addr --               fig             spstore  sp!     a_addr --               fig             spstore
sp = a_addr+1;  sp = a_addr;
/* works with and without TOS caching */  /* works with and without TOS caching */

rp@     -- a_addr               fig             rpat  rp@     -- a_addr               fig             rpat
 Line 488
 Line 609
i'      -- w            fig             i_tick  i'      -- w            fig             i_tick
w=rp[1];  w=rp[1];

2>r     w1 w2 --        core-ext        two_to_r
*--rp = w1;
*--rp = w2;

2r>     -- w1 w2        core-ext        two_r_from
w2 = *rp++;
w1 = *rp++;

2r@     -- w1 w2        core-ext        two_r_fetch
w2 = rp[0];
w1 = rp[1];

2rdrop  --              new     two_r_drop
rp+=2;

over    w1 w2 -- w1 w2 w1               core,fig  over    w1 w2 -- w1 w2 w1               core,fig

drop    w --            core,fig  drop    w --            core,fig
 Line 499
 Line 635
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 511
 Line 653
*--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 545
 Line 701
2!      w1 w2 a_addr --         core    two_store  2!      w1 w2 a_addr --         core    two_store
a_addr[0] = w2;  a_addr[0] = w2;
a_addr[1] = w1;  a_addr[1] = w1;
:
tuck ! cell+ ! ;

2@      a_addr -- w1 w2         core    two_fetch  2@      a_addr -- w1 w2         core    two_fetch
w2 = a_addr[0];  w2 = a_addr[0];
w1 = a_addr[1];  w1 = a_addr[1];
:
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 559
 Line 719

cell+   a_addr1 -- a_addr2      core    cell_plus  cell+   a_addr1 -- a_addr2      core    cell_plus
a_addr2 = a_addr1+1;  a_addr2 = a_addr1+1;
:
[ 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 ] ;

char+   c_addr1 -- c_addr2      core    care_plus  char+   c_addr1 -- c_addr2      core    care_plus
c_addr2 = c_addr1+1;  c_addr2 = c_addr1+1;
:
1+ ;

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

count   c_addr1 -- c_addr2 u    core  count   c_addr1 -- c_addr2 u    core
u = *c_addr1;  u = *c_addr1;
c_addr2 = c_addr1+1;  c_addr2 = c_addr1+1;
:
dup 1+ swap c@ ;

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

system  c_addr u -- n   own  system  c_addr u -- n   own
char pname[u+1];  n=system(cstr(c_addr,u,1));
cstr(pname,c_addr,u);
n=system(pname);  getenv  c_addr1 u1 -- c_addr2 u2        new
c_addr2 = getenv(cstr(c_addr1,u1,1));
u2=strlen(c_addr2);

popen   c_addr u n -- wfileid   own  popen   c_addr u n -- wfileid   own
char pname[u+1];
static char* mode[2]={"r","w"};  static char* mode[2]={"r","w"};
cstr(pname,c_addr,u);  wfileid=(Cell)popen(cstr(c_addr,u,1),mode[n]);
wfileid=(Cell)popen(pname,mode[n]);

pclose  wfileid -- wior own  pclose  wfileid -- wior own
wior=pclose((FILE *)wfileid);  wior=pclose((FILE *)wfileid);

time&date       -- nyear nmonth nday nhour nmin nsec    ansi    time_and_date  time&date       -- nyear nmonth nday nhour nmin nsec    facility-ext    time_and_date
struct timeval time1;  struct timeval time1;
struct timezone zone1;  struct timezone zone1;
struct tm *ltime;  struct tm *ltime;
 Line 604
 Line 778
nmin  =ltime->tm_min;  nmin  =ltime->tm_min;
nsec  =ltime->tm_sec;  nsec  =ltime->tm_sec;

ms      n --    ansi  ms      n --    facility-ext
struct timeval timeout;  struct timeval timeout;
timeout.tv_sec=n/1000;  timeout.tv_sec=n/1000;
timeout.tv_usec=1000*(n%1000);  timeout.tv_usec=1000*(n%1000);
 Line 625
 Line 799
(f83find)       c_addr u f83name1 -- f83name2   new     paren_f83find  (f83find)       c_addr u f83name1 -- f83name2   new     paren_f83find
for (; f83name1 != NULL; f83name1 = f83name1->next)  for (; f83name1 != NULL; f83name1 = f83name1->next)
if (F83NAME_COUNT(f83name1)==u &&    if (F83NAME_COUNT(f83name1)==u &&
strncmp(c_addr, f83name1->name, u)== 0 /* or inline? */)        strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
break;      break;
f83name2=f83name1;  f83name2=f83name1;
:
(f83casefind)   c_addr u f83name1 -- f83name2   new     paren_f83casefind   BEGIN  dup  WHILE
for (; f83name1 != NULL; f83name1 = f83name1->next)          >r dup r@ cell+ c@ \$1F and =
IF  2dup r@ cell+ char+ capscomp  0=
IF  2drop r>  EXIT  THEN  THEN
r> @
REPEAT  nip nip ;

(hashfind)      c_addr u a_addr -- f83name2     new     paren_hashfind
F83Name *f83name1;
f83name2=NULL;
while(a_addr != NULL)
{
f83name1=(F83Name *)(a_addr[1]);
a_addr=(Cell *)(a_addr[0]);
if (F83NAME_COUNT(f83name1)==u &&    if (F83NAME_COUNT(f83name1)==u &&
strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)        strncasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
break;       {
f83name2=f83name1;  f83name2=f83name1;
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
u2=0;
while(u1--)
u2+=(int)toupper(*c_addr++);
:
0 -rot bounds ?DO  I c@ toupper +  LOOP ;

(hashkey1)      c_addr u ubits -- ukey          new     paren_hashkey1
""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
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
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,

(parse-white)   c_addr1 u1 -- c_addr2 u2        new     paren_parse_white  (parse-white)   c_addr1 u1 -- c_addr2 u2        new     paren_parse_white
/* use !isgraph instead of isspace? */  /* use !isgraph instead of isspace? */
 Line 650
 Line 880
c_addr2 = c_addr1;    c_addr2 = c_addr1;
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);

open-file       c_addr u ntype -- w2 wior       file    open_file  open-file       c_addr u ntype -- w2 wior       file    open_file
char fname[u+1];  w2 = (Cell)fopen(cstr(c_addr, u, 1), fileattr[ntype]);
cstr(fname, c_addr, u);
w2 = (Cell)fopen(fname, fileattr[ntype]);
wior =  FILEEXIST(w2 == NULL);  wior =  FILEEXIST(w2 == NULL);

create-file     c_addr u ntype -- w2 wior       file    create_file  create-file     c_addr u ntype -- w2 wior       file    create_file
int     fd;  int     fd;
char fname[u+1];  fd = creat(cstr(c_addr, u, 1), 0644);
cstr(fname, c_addr, u);
fd = creat(fname, 0666);
if (fd > -1) {  if (fd > -1) {
w2 = (Cell)fdopen(fd, fileattr[ntype]);    w2 = (Cell)fdopen(fd, fileattr[ntype]);
assert(w2 != NULL);    assert(w2 != NULL);
 Line 676
 Line 907
}  }

delete-file     c_addr u -- wior                file    delete_file  delete-file     c_addr u -- wior                file    delete_file
char fname[u+1];  wior = FILEEXIST(unlink(cstr(c_addr, u, 1)));
cstr(fname, c_addr, u);
wior = FILEEXIST(unlink(fname));

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 fname1[u1+1];  char *s1=cstr(c_addr2, u2, 1);
char fname2[u2+1];  wior = FILEEXIST(rename(cstr(c_addr1, u1, 0), s1));
cstr(fname1, c_addr1, u1);
cstr(fname2, c_addr2, u2);
wior = FILEEXIST(rename(fname1, fname2));

file-position   wfileid -- ud wior      file    file_position  file-position   wfileid -- ud wior      file    file_position
/* !! use tell and lseek? */  /* !! use tell and lseek? */
 Line 710
 Line 936
/* !! who performs clearerr((FILE *)wfileid); ? */  /* !! who performs clearerr((FILE *)wfileid); ? */

read-line       c_addr u1 wfileid -- u2 flag wior       file    read_line  read-line       c_addr u1 wfileid -- u2 flag wior       file    read_line
if ((flag=FLAG(!feof((FILE *)wfileid)))) {  /*
char *s = fgets(c_addr,u1+1,(FILE *)wfileid);  Cell c;
flag=-1;
for(u2=0; u2<u1; u2++)
{
*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));    wior=FILEIO(ferror((FILE *)wfileid));
u2=strlen(c_addr);    u2=strlen(c_addr);
u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));    u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));
 Line 842
 Line 1083
>float  c_addr u -- flag        float   to_float  >float  c_addr u -- flag        float   to_float
/* real signature: c_addr u -- r t / f */  /* real signature: c_addr u -- r t / f */
Float r;  Float r;
char number[u+1];  char *number=cstr(c_addr, u, 1);
char *endconv;  char *endconv;
cstr(number, c_addr, u);
r=strtod(number,&endconv);  r=strtod(number,&endconv);
if((flag=FLAG(!(int)*endconv)))  if((flag=FLAG(!(int)*endconv)))
{  {
 Line 887
 Line 1127

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 898
 Line 1138

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 971
 Line 1211
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));

laddr#          -- c_addr       new     laddr_number  laddr#          -- c_addr       new     laddr_number
/* this can also be used to implement lp@ */  /* this can also be used to implement lp@ */
 Line 1001
 Line 1241
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);

lp!     c_addr --       new     lp_store  lp!     c_addr --       new     lp_store
lp = (Address)c_addr;  lp = (Address)c_addr;
 Line 1022
 Line 1262
*(Float *)lp = r;  *(Float *)lp = r;

up!     a_addr --       new     up_store  up!     a_addr --       new     up_store
up=(char *)a_addr;  up0=up=(char *)a_addr;

Generate output suitable for use with a patch program
Legend:
 Removed from v.1.11 changed lines Added in v.1.19

CVS Admin

Powered by ViewCVS 1.0-dev