Diff for /gforth/prim between versions 1.59 and 1.65

version 1.59, 2000/09/09 20:32:58 version 1.65, 2000/11/12 18:14:09
Line 1 Line 1
 \ Gforth primitives  \ Gforth primitives
   
 \ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 16 Line 16
   
 \ 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, write to the Free Software
 \ Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.  \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   
   
 \ WARNING: This file is processed by m4. Make sure your identifiers  \ WARNING: This file is processed by m4. Make sure your identifiers
Line 117  INC_IP(1); Line 117  INC_IP(1);
 execute ( xt -- )               core  execute ( xt -- )               core
 ""Perform the semantics represented by the execution token, @i{xt}.""  ""Perform the semantics represented by the execution token, @i{xt}.""
 ip=IP;  ip=IP;
 IF_TOS(TOS = sp[0]);  IF_spTOS(spTOS = sp[0]);
 EXEC(xt);  EXEC(xt);
   
 perform ( a_addr -- )   gforth  perform ( a_addr -- )   gforth
 ""@code{@@ execute}.""  ""@code{@@ execute}.""
 /* and pfe */  /* and pfe */
 ip=IP;  ip=IP;
 IF_TOS(TOS = sp[0]);  IF_spTOS(spTOS = sp[0]);
 EXEC(*(Xt *)a_addr);  EXEC(*(Xt *)a_addr);
 :  :
  @ execute ;   @ execute ;
Line 134  EXEC(*(Xt *)a_addr); Line 134  EXEC(*(Xt *)a_addr);
   
 branch-lp+!#    ( -- )  gforth  branch_lp_plus_store_number  branch-lp+!#    ( -- )  gforth  branch_lp_plus_store_number
 /* this will probably not be used */  /* this will probably not be used */
 branch_adjust_lp:  
 lp += (Cell)(IP[1]);  lp += (Cell)(IP[1]);
 goto branch;  goto branch;
   
Line 151  SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST Line 150  SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST
 define(condbranch,  define(condbranch,
 $1      $2  $1      $2
 $3      SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));  $3      SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
         NEXT;  
 }  }
 else  else
     INC_IP(1);      INC_IP(1);
Line 160  $4 Line 158  $4
 \+glocals  \+glocals
   
 $1-lp+!#        $2_lp_plus_store_number  $1-lp+!#        $2_lp_plus_store_number
 $3    goto branch_adjust_lp;  $3    lp += (Cell)(IP[1]);
   SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
 }  }
 else  else
     INC_IP(2);      INC_IP(2);
Line 170  else Line 169  else
   
 condbranch(?branch,( f -- )             f83     question_branch,  condbranch(?branch,( f -- )             f83     question_branch,
 if (f==0) {  if (f==0) {
     IF_TOS(TOS = sp[0]);      IF_spTOS(spTOS = sp[0]);
 ,:  ,:
  0= dup     \ !f !f   0= dup     \ !f !f
  r> dup @   \ !f !f IP branchoffset   r> dup @   \ !f !f IP branchoffset
Line 187  if (f==0) { Line 186  if (f==0) {
 ""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++;    sp++;
   IF_TOS(TOS = sp[0]);    IF_spTOS(spTOS = sp[0]);
   SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));    SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
   NEXT;    NEXT;
 }  }
Line 212  else Line 211  else
 \f[THEN]  \f[THEN]
 \fhas? skiploopprims 0= [IF]  \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 dup @ + >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 dup @ + >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;
   n2=n1+n;        
 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 */) {
 #ifdef i386  
     *rp += n;  
 #else  
     *rp = index + n;  
 #endif  
     IF_TOS(TOS = sp[0]);  
 ,:  ,:
  r> swap   r> swap
  r> r> 2dup - >r   r> r> 2dup - >r
Line 252  if ((olddiff^(olddiff+n))>=0   /* the li Line 244  if ((olddiff^(olddiff+n))>=0   /* the li
   
 \+xconds  \+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;
 }  }
   n2=n1+n;
 if (diff>=0 || newdiff<0) {  if (diff>=0 || newdiff<0) {
 #ifdef i386  
     *rp += n;  
 #else  
     *rp = index + n;  
 #endif  
     IF_TOS(TOS = sp[0]);  
 ,)  ,)
   
 \+  \+
   
 unloop  ( -- )  core  unloop  ( R:w1 R:w2 -- )        core
 rp += 2;  /* !! alias for 2rdrop */
 :  :
  r> rdrop rdrop >r ;   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)   ( nlimit nstart -- R:nlimit R:nstart )  gforth  paren_question_do
 *--rp = nlimit;  
 *--rp = nstart;  
 if (nstart == nlimit) {  if (nstart == nlimit) {
     IF_TOS(TOS = sp[0]);      IF_spTOS(spTOS = sp[0]);
     goto branch;      goto branch;
     }      }
 else {  else {
Line 327  else { Line 300  else {
   
 \+xconds  \+xconds
   
 (+do)   ( nlimit nstart -- )    gforth  paren_plus_do  (+do)   ( nlimit nstart -- R:nlimit R:nstart )  gforth  paren_plus_do
 *--rp = nlimit;  
 *--rp = nstart;  
 if (nstart >= nlimit) {  if (nstart >= nlimit) {
     IF_TOS(TOS = sp[0]);      IF_spTOS(spTOS = sp[0]);
     goto branch;      goto branch;
     }      }
 else {  else {
Line 347  else { Line 318  else {
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 (u+do)  ( ulimit ustart -- )    gforth  paren_u_plus_do  (u+do)  ( ulimit ustart -- R:ulimit R:ustart )  gforth  paren_u_plus_do
 *--rp = ulimit;  
 *--rp = ustart;  
 if (ustart >= ulimit) {  if (ustart >= ulimit) {
     IF_TOS(TOS = sp[0]);      IF_spTOS(spTOS = sp[0]);
     goto branch;      goto branch;
     }      }
 else {  else {
Line 367  else { Line 336  else {
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 (-do)   ( nlimit nstart -- )    gforth  paren_minus_do  (-do)   ( nlimit nstart -- R:nlimit R:nstart )  gforth  paren_minus_do
 *--rp = nlimit;  
 *--rp = nstart;  
 if (nstart <= nlimit) {  if (nstart <= nlimit) {
     IF_TOS(TOS = sp[0]);      IF_spTOS(spTOS = sp[0]);
     goto branch;      goto branch;
     }      }
 else {  else {
Line 387  else { Line 354  else {
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 (u-do)  ( ulimit ustart -- )    gforth  paren_u_minus_do  (u-do)  ( ulimit ustart -- R:ulimit R:ustart )  gforth  paren_u_minus_do
 *--rp = ulimit;  
 *--rp = ustart;  
 if (ustart <= ulimit) {  if (ustart <= ulimit) {
     IF_TOS(TOS = sp[0]);      IF_spTOS(spTOS = sp[0]);
     goto branch;      goto branch;
     }      }
 else {  else {
Line 412  else { Line 377  else {
 \ don't make any assumptions where the return stack is!!  \ don't make any assumptions where the return stack is!!
 \ implement this in machine code if it should run quickly!  \ implement this in machine code if it should run quickly!
   
 i       ( -- n )                core  i       ( R:n -- R:n n )                core
 n = *rp;  
 :  :
 \ rp@ cell+ @ ;  \ rp@ cell+ @ ;
   r> r> tuck >r >r ;    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 @ ;    r> r> r> dup itmp ! >r >r >r itmp @ ;
 variable itmp  variable itmp
   
 j       ( -- n )                core  j       ( R:n R:d1 -- n R:n R:d1 )              core
 n = rp[2];  
 :  :
 \ rp@ cell+ cell+ cell+ @ ;  \ rp@ cell+ cell+ cell+ @ ;
   r> r> r> r> dup itmp ! >r >r >r >r itmp @ ;    r> r> r> r> dup itmp ! >r >r >r >r itmp @ ;
 [IFUNDEF] itmp variable itmp [THEN]  [IFUNDEF] itmp variable itmp [THEN]
   
 k       ( -- n )                gforth  k       ( R:n R:d1 R:d2 -- n R:n R:d1 R:d2 )            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 @ ;    r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ;
Line 955  a_addr = sp+1; Line 915  a_addr = sp+1;
   
 sp!     ( a_addr -- )           gforth          sp_store  sp!     ( a_addr -- )           gforth          sp_store
 sp = a_addr;  sp = a_addr;
 /* works with and without TOS caching */  /* works with and without spTOS caching */
   
 rp@     ( -- a_addr )           gforth          rp_fetch  rp@     ( -- a_addr )           gforth          rp_fetch
 a_addr = rp;  a_addr = rp;
Line 973  fp = f_addr; Line 933  fp = f_addr;
   
 \+  \+
   
 ;s      ( -- )          gforth  semis  ;s      ( R:w -- )              gforth  semis
 ""The primitive compiled by @code{EXIT}.""  ""The primitive compiled by @code{EXIT}.""
 SET_IP((Xt *)(*rp++));  SET_IP((Xt *)w);
   
 >r      ( w -- )                core    to_r  >r      ( w -- R:w )            core    to_r
 ""@code{( R: -- w )}""  
 *--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
 ""@code{( R: w -- )}""  
 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
 ""@code{( R: w -- )}""  
 rp++;  
 :  :
  r> r> drop >r ;   r> r> drop >r ;
   
 2>r     ( w1 w2 -- )    core-ext        two_to_r  2>r     ( w1 w2 -- R:w1 R:w2 )  core-ext        two_to_r
 ""@code{( R: -- w1 w2 )}""  
 *--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:w1 R:w2 -- w1 w2 )  core-ext        two_r_from
 ""@code{( R: w1 w2 -- )}""  
 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:w1 R:w2 -- R:w1 R:w2 w1 w2 )        core-ext        two_r_fetch
 ""@code{( R: w1 w2 -- w1 w2 )}""  
 w2 = rp[0];  
 w1 = rp[1];  
 :  :
  i' j ;   i' j ;
   
 2rdrop  ( -- )          gforth  two_r_drop  2rdrop  (  R:w1 R:w2 -- )               gforth  two_r_drop
 ""@code{( R: w1 w2 -- )}""  
 rp+=2;  
 :  :
  r> r> drop r> drop >r ;   r> r> drop r> drop >r ;
   
Line 1066  tuck ( w1 w2 -- w2 w1 w2 ) core-ext Line 1009  tuck ( w1 w2 -- w2 w1 w2 ) core-ext
 ""Actually the stack effect is: @code{( w -- 0 | w w )}.  It performs a  ""Actually the stack effect is: @code{( w -- 0 | w w )}.  It performs a
 @code{dup} if w is nonzero.""  @code{dup} if w is nonzero.""
 if (w!=0) {  if (w!=0) {
   IF_TOS(*sp-- = w;)    IF_spTOS(*sp-- = w;)
 #ifndef USE_TOS  #ifndef USE_TOS
   *--sp = w;    *--sp = w;
 #endif  #endif
Line 1584  access the stack itself. The stack point Line 1527  access the stack itself. The stack point
 variables @code{SP} and @code{FP}.""  variables @code{SP} and @code{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;  FP=fp;
 SP=sp;  SP=sp;
 ((void (*)())w)();  ((void (*)())w)();
 sp=SP;  sp=SP;
 fp=FP;  fp=FP;
 IF_TOS(TOS=sp[0]);  IF_spTOS(spTOS=sp[0]);
 IF_FTOS(FTOS=fp[0]);  IF_fpTOS(fpTOS=fp[0]);
   
 \+  \+
 \+file  \+file
Line 1646  wior = FILEIO(u2<u1 && ferror((FILE *)wf Line 1589  wior = FILEIO(u2<u1 && ferror((FILE *)wf
 if (wior)  if (wior)
   clearerr((FILE *)wfileid);    clearerr((FILE *)wfileid);
   
 (read-line)     ( c_addr u1 wfileid -- u2 flag wior u3 )        file    read_line  read-line       ( c_addr u1 wfileid -- u2 flag wior )   file    read_line
 #if 1  ""this is only for backward compatibility""
 Cell c;  Cell c;
 flag=-1;  flag=-1;
 u3=0;  
 for(u2=0; u2<u1; u2++)  for(u2=0; u2<u1; u2++)
 {  {
    c = getc((FILE *)wfileid);     c = getc((FILE *)wfileid);
    u3++;  
    if (c=='\n') break;     if (c=='\n') break;
    if (c=='\r') {     if (c=='\r') {
      if ((c = getc((FILE *)wfileid))!='\n')       if ((c = getc((FILE *)wfileid))!='\n')
        ungetc(c,(FILE *)wfileid);         ungetc(c,(FILE *)wfileid);
      else  
        u3++;  
      break;       break;
    }     }
    if (c==EOF) {     if (c==EOF) {
Line 1670  for(u2=0; u2<u1; u2++) Line 1609  for(u2=0; u2<u1; u2++)
    c_addr[u2] = (Char)c;     c_addr[u2] = (Char)c;
 }  }
 wior=FILEIO(ferror((FILE *)wfileid));  wior=FILEIO(ferror((FILE *)wfileid));
 #else  
 if ((flag=FLAG(!feof((FILE *)wfileid) &&  
                fgets(c_addr,u1+1,(FILE *)wfileid) != NULL))) {  
   wior=FILEIO(ferror((FILE *)wfileid)!=0); /* !! ior? */  
   if (wior)  
     clearerr((FILE *)wfileid);  
   u2 = strlen(c_addr);  
   u2-=((u2>0) && (c_addr[u2-1]==NEWLINE));  
 }  
 else {  
   wior=0;  
   u2=0;  
 }  
 #endif  
   
 \+  \+
   
Line 1910  number[u]='\0'; Line 1835  number[u]='\0';
 r=strtod(number,&endconv);  r=strtod(number,&endconv);
 if((flag=FLAG(!(Cell)*endconv)))  if((flag=FLAG(!(Cell)*endconv)))
 {  {
    IF_FTOS(fp[0] = FTOS);     IF_fpTOS(fp[0] = fpTOS);
    fp += -1;     fp += -1;
    FTOS = sign ? -r : r;     fpTOS = sign ? -r : r;
 }  }
 else if(*endconv=='d' || *endconv=='D')  else if(*endconv=='d' || *endconv=='D')
 {  {
Line 1920  else if(*endconv=='d' || *endconv=='D') Line 1845  else if(*endconv=='d' || *endconv=='D')
    r=strtod(number,&endconv);     r=strtod(number,&endconv);
    if((flag=FLAG(!(Cell)*endconv)))     if((flag=FLAG(!(Cell)*endconv)))
      {       {
         IF_FTOS(fp[0] = FTOS);          IF_fpTOS(fp[0] = fpTOS);
         fp += -1;          fp += -1;
         FTOS = sign ? -r : r;          fpTOS = sign ? -r : r;
      }       }
 }  }
   
Line 2214  UP=up=(char *)a_addr; Line 2139  UP=up=(char *)a_addr;
 Variable UP  Variable UP
   
 wcall   ( u -- )        gforth  wcall   ( u -- )        gforth
 IF_FTOS(fp[0]=FTOS);  IF_fpTOS(fp[0]=fpTOS);
 FP=fp;  FP=fp;
 sp=(SYSCALL(Cell(*)(Cell *, void *))u)(sp, &FP);  sp=(SYSCALL(Cell(*)(Cell *, void *))u)(sp, &FP);
 fp=FP;  fp=FP;
 IF_TOS(TOS=sp[0];)  IF_spTOS(spTOS=sp[0];)
 IF_FTOS(FTOS=fp[0]);  IF_fpTOS(fpTOS=fp[0]);
   
 \+file  \+file
   
Line 2328  for (; ucount>0; ucount--) { Line 2253  for (; ucount>0; ucount--) {
  LOOP 2drop 2drop fdrop ;   LOOP 2drop 2drop fdrop ;
   
 \+  \+
   
   \+file
   
   (read-line)     ( c_addr u1 wfileid -- u2 flag u3 wior )        file    paren_read_line
   Cell c;
   flag=-1;
   u3=0;
   for(u2=0; u2<u1; u2++)
   {
      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;
        }
      c_addr[u2] = (Char)c;
   }
   wior=FILEIO(ferror((FILE *)wfileid));
   
   \+

Removed from v.1.59  
changed lines
  Added in v.1.65


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