[gforth] / gforth / prim

# gforth: gforth/prim

### Diff for /gforth/prim between version 1.124 and 1.125

version 1.124, Sat Jan 25 13:44:54 2003 UTC version 1.125, Sun Jan 26 20:56:37 2003 UTC
 Line 557
 Line 557
@i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}  @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  from low address to high address; i.e., for overlapping areas it is
safe if @i{c-to}=<@i{c-from}.""  safe if @i{c-to}=<@i{c-from}.""
while (u-- > 0)  cmove(c_from,c_to,u);
*c_to++ = *c_from++;
:  :
bounds ?DO  dup c@ I c! 1+  LOOP  drop ;   bounds ?DO  dup c@ I c! 1+  LOOP  drop ;

 Line 567
 Line 566
@i{c-from} to @i{c-to}. The copy proceeds @code{char}-by-@code{char}  @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  from high address to low address; i.e., for overlapping areas it is
safe if @i{c-to}>=@i{c-from}.""  safe if @i{c-to}>=@i{c-from}.""
while (u-- > 0)  cmove_up(c_from,c_to,u);
c_to[u] = c_from[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-
 Line 588
 Line 586
comparison. In the future, this may change to consider the current  comparison. In the future, this may change to consider the current
locale and its collation order.""  locale and its collation order.""
/* close ' to keep fontify happy */  /* close ' to keep fontify happy */
if (n==0)
n = u1-u2;
if (n<0)
n = -1;
else if (n>0)
n = 1;
:  :
rot 2dup swap - >r min swap -text dup   rot 2dup swap - >r min swap -text dup
IF  rdrop  ELSE  drop r> sgn  THEN ;   IF  rdrop  ELSE  drop r> sgn  THEN ;
: sgn ( n -- -1/0/1 )  : sgn ( n -- -1/0/1 )
dup 0= IF EXIT THEN  0< 2* 1+ ;   dup 0= IF EXIT THEN  0< 2* 1+ ;

-text   ( c_addr1 u c_addr2 -- n )      new     dash_text  \ -text is only used by replaced primitives now; move it elsewhere
n = -1;  \ if (n<0)
else if (n>0)  \   n = -1;
n = 1;  \ else if (n>0)
:  \   n = 1;
swap bounds  \ :
?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0  \  swap bounds
ELSE  c@ I c@ - unloop  THEN  sgn ;  \  ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0
: sgn ( n -- -1/0/1 )  \  ELSE  c@ I c@ - unloop  THEN  sgn ;
dup 0= IF EXIT THEN  0< 2* 1+ ;  \ : sgn ( n -- -1/0/1 )
\  dup 0= IF EXIT THEN  0< 2* 1+ ;

toupper ( c1 -- c2 )    gforth  toupper ( c1 -- c2 )    gforth
""If @i{c1} is a lower-case character (in the current locale), @i{c2}  ""If @i{c1} is a lower-case character (in the current locale), @i{c2}
 Line 621
 Line 614
:  :
dup [char] a - [ char z char a - 1 + ] Literal u<  bl and - ;   dup [char] a - [ char z char a - 1 + ] Literal u<  bl and - ;

n = memcasecmp(c_addr1, c_addr2, u); /* !! use something that works in all locales */
if (n<0)
n = -1;
else if (n>0)
n = 1;
:
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 ;

spaces. @i{u2} is the length of the modified string.""
u2 = u1;
while (u2>0 && c_addr[u2-1] == ' ')
u2--;
:
BEGIN  1- 2dup + c@ bl =  WHILE
dup  0= UNTIL  ELSE  1+  THEN ;

characters from the start of the string.""  characters from the start of the string.""
 Line 1343
 Line 1313
\g compiler  \g compiler

(listlfind)     ( c_addr u longname1 -- longname2 )     new     paren_listlfind  (listlfind)     ( c_addr u longname1 -- longname2 )     new     paren_listlfind
for (; longname1 != NULL; longname1 = (struct Longname *)(longname1->next))  longname2=listlfind(c_addr, u, longname1);
if ((UCell)LONGNAME_COUNT(longname1)==u &&
memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */)
break;
longname2=longname1;
:  :
BEGIN  dup WHILE  (findl-samelen)  dup  WHILE      BEGIN  dup WHILE  (findl-samelen)  dup  WHILE
>r 2dup r@ cell+ cell+ capscomp  0=          >r 2dup r@ cell+ cell+ capscomp  0=
 Line 1360
 Line 1326
\+hash  \+hash

longname2=NULL;
{
if ((UCell)LONGNAME_COUNT(longname1)==u &&
memcasecmp(c_addr, longname1->name, u)== 0 /* or inline? */)
{
longname2=longname1;
break;
}
}
:  :
BEGIN  dup  WHILE   BEGIN  dup  WHILE
2@ >r >r dup r@ cell+ @ lcount-mask and =          2@ >r >r dup r@ cell+ @ lcount-mask and =
 Line 1383
 Line 1337

""A case-sensitive variant of @code{(hashfind)}""  ""A case-sensitive variant of @code{(hashfind)}""
longname2=NULL;
{
if ((UCell)LONGNAME_COUNT(longname1)==u &&
memcmp(c_addr, longname1->name, u)== 0 /* or inline? */)
{
longname2=longname1;
break;
}
}
:  :
BEGIN  dup  WHILE   BEGIN  dup  WHILE
2@ >r >r dup r@ cell+ @ lcount-mask and =          2@ >r >r dup r@ cell+ @ lcount-mask and =
 Line 1406
 Line 1348

(hashkey1)      ( c_addr u ubits -- ukey )              gforth  paren_hashkey1  (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.
*/
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)))
^ 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
 Line 1435
 Line 1365
\+  \+

;
}
else {
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
 Line 1538
 Line 1458
SUPER_END;  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
#ifndef MSDOS  #ifndef MSDOS
int old_tp=terminal_prepped;  int old_tp=terminal_prepped;
deprep_terminal();  deprep_terminal();
 Line 1674
 Line 1594

wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);

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 1702
 Line 1621
clearerr((FILE *)wfileid);    clearerr((FILE *)wfileid);

flag=-1;  u2   = r.n1;
u3=0;  flag = r.n2;
for(u2=0; u2<u1; u2++)  u3   = r.n3;
{  wior = r.n4;
c = getc((FILE *)wfileid);
u3++;
if (c=='\n') break;
if (c=='\r') {
if ((c = getc((FILE *)wfileid))!='\n')
ungetc(c,(FILE *)wfileid);
else
u3++;
break;
}
if (c==EOF) {
flag=FLAG(u2!=0);
break;
}
}
wior=FILEIO(ferror((FILE *)wfileid));

\+  \+

 Line 1755
 Line 1657
wior = IOR(fflush((FILE *) wfileid)==EOF);  wior = IOR(fflush((FILE *) wfileid)==EOF);

file-status     ( c_addr u -- wfam wior )       file-ext        file_status  file-status     ( c_addr u -- wfam wior )       file-ext        file_status
if (access (filename, F_OK) != 0) {  wfam = r.n1;
wfam=0;  wior = r.n2;
wior=IOR(1);
}
else if (access (filename, R_OK | W_OK) == 0) {
wfam=2; /* r/w */
wior=0;
}
else if (access (filename, R_OK) == 0) {
wfam=0; /* r/o */
wior=0;
}
else if (access (filename, W_OK) == 0) {
wfam=4; /* w/o */
wior=0;
}
else {
wfam=1; /* well, we cannot access the file, but better deliver a legal
access mode (r/o bin), so we get a decent error later upon open. */
wior=0;
}

file-eof?       ( wfileid -- flag )     gforth  file_eof_query  file-eof?       ( wfileid -- flag )     gforth  file_eof_query
flag = FLAG(feof((FILE *) wfileid));  flag = FLAG(feof((FILE *) wfileid));
 Line 2024
 Line 1907
@i{r} is placed on the floating-point stack and @i{flag} is  @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  true. Otherwise, @i{flag} is false. A string of blanks is a special
case and represents the floating-point number 0.""  case and represents the floating-point number 0.""
/* real signature: c_addr u -- r t / f */
Float r;  Float r;
char *endconv;  if (flag) {
int sign = 0;
if(number[0]=='-') {
sign = 1;
number++;
u--;
}
while(isspace((unsigned)(number[--u])) && u>0);
switch(number[u])
{
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_fpTOS(fp[0] = fpTOS);     IF_fpTOS(fp[0] = fpTOS);
fp += -1;     fp += -1;
fpTOS = sign ? -r : r;    fpTOS = r;
}
else if(*endconv=='d' || *endconv=='D')
{
*endconv='E';
r=strtod(number,&endconv);
if((flag=FLAG(!(Cell)*endconv)))
{
IF_fpTOS(fp[0] = fpTOS);
fp += -1;
fpTOS = sign ? -r : r;
}
}  }

fabs    ( r1 -- r2 )    float-ext       f_abs  fabs    ( r1 -- r2 )    float-ext       f_abs
 Line 2199
 Line 2051
""dot-product: r=v1*v2.  The first element of v1 is at f_addr1, the  ""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  next at f_addr1+nstride1 and so on (similar for v2). Both vectors have
ucount elements.""  ucount elements.""
for (r=0.; ucount>0; ucount--) {  r = v_star(f_addr1, nstride1, f_addr2, nstride2, ucount);
}
:  :
>r swap 2swap swap 0e r> 0 ?DO   >r swap 2swap swap 0e r> 0 ?DO
dup f@ over + 2swap dup f@ f* f+ over + 2swap       dup f@ over + 2swap dup f@ f* f+ over + 2swap
 Line 2211
 Line 2059

faxpy   ( ra f_x nstridex f_y nstridey ucount -- )      gforth  faxpy   ( ra f_x nstridex f_y nstridey ucount -- )      gforth
""vy=ra*vx+vy""  ""vy=ra*vx+vy""
for (; ucount>0; ucount--) {  faxpy(ra, f_x, nstridex, f_y, nstridey, ucount);
*f_y += ra * *f_x;
}
:  :
>r swap 2swap swap r> 0 ?DO   >r swap 2swap swap r> 0 ?DO
fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap       fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap

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