Diff for /gforth/prim between versions 1.56 and 1.64

version 1.56, 2000/08/17 12:46:57 version 1.64, 2000/11/10 10:04:20
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 170  else Line 170  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 187  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 241  if ((olddiff^(olddiff+n))>=0   /* the li Line 241  if ((olddiff^(olddiff+n))>=0   /* the li
 #else  #else
     *rp = index + n;      *rp = index + n;
 #endif  #endif
     IF_TOS(TOS = sp[0]);      IF_spTOS(spTOS = sp[0]);
 ,:  ,:
  r> swap   r> swap
  r> r> 2dup - >r   r> r> 2dup - >r
Line 262  if (olddiff>u) { Line 262  if (olddiff>u) {
 #else  #else
     *rp = index - u;      *rp = index - u;
 #endif  #endif
     IF_TOS(TOS = sp[0]);      IF_spTOS(spTOS = sp[0]);
 ,)  ,)
   
 condbranch((s+loop),( n -- )            gforth  paren_symmetric_plus_loop,  condbranch((s+loop),( n -- )            gforth  paren_symmetric_plus_loop,
Line 283  if (diff>=0 || newdiff<0) { Line 283  if (diff>=0 || newdiff<0) {
 #else  #else
     *rp = index + n;      *rp = index + n;
 #endif  #endif
     IF_TOS(TOS = sp[0]);      IF_spTOS(spTOS = sp[0]);
 ,)  ,)
   
 \+  \+
Line 311  rp += 2; Line 311  rp += 2;
 *--rp = nlimit;  *--rp = nlimit;
 *--rp = nstart;  *--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 331  else { Line 331  else {
 *--rp = nlimit;  *--rp = nlimit;
 *--rp = nstart;  *--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 351  else { Line 351  else {
 *--rp = ulimit;  *--rp = ulimit;
 *--rp = ustart;  *--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 371  else { Line 371  else {
 *--rp = nlimit;  *--rp = nlimit;
 *--rp = nstart;  *--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 391  else { Line 391  else {
 *--rp = ulimit;  *--rp = ulimit;
 *--rp = ustart;  *--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 955  a_addr = sp+1; Line 955  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 1066  tuck ( w1 w2 -- w2 w1 w2 ) core-ext Line 1066  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 1379  c_addr = (Address)CODE_ADDRESS(xt); Line 1379  c_addr = (Address)CODE_ADDRESS(xt);
     @ ;      @ ;
   
 >does-code      ( xt -- a_addr )                gforth  to_does_code  >does-code      ( xt -- a_addr )                gforth  to_does_code
 ""If @i{xt} is the execution token of a defining-word-defined word,  ""If @i{xt} is the execution token of a child of a @code{DOES>} word,
 @i{a-addr} is the start of the Forth code after the @code{DOES>};  @i{a-addr} is the start of the Forth code after the @code{DOES>};
 Otherwise @i{a-addr} is 0.""  Otherwise @i{a-addr} is 0.""
 a_addr = (Cell *)DOES_CODE(xt);  a_addr = (Cell *)DOES_CODE(xt);
Line 1394  CACHE_FLUSH(xt,(size_t)PFA(0)); Line 1394  CACHE_FLUSH(xt,(size_t)PFA(0));
     ! ;      ! ;
   
 does-code!      ( a_addr xt -- )                gforth  does_code_store  does-code!      ( a_addr xt -- )                gforth  does_code_store
 ""Create a code field at @i{xt} for a defining-word-defined word; @i{a-addr}  ""Create a code field at @i{xt} for a child of a @code{DOES>}-word;
 is the start of the Forth code after @code{DOES>}.""  @i{a-addr} is the start of the Forth code after @code{DOES>}.""
 MAKE_DOES_CF(xt, a_addr);  MAKE_DOES_CF(xt, a_addr);
 CACHE_FLUSH(xt,(size_t)PFA(0));  CACHE_FLUSH(xt,(size_t)PFA(0));
 :  :
     dodoes: over ! cell+ ! ;      dodoes: over ! cell+ ! ;
   
 does-handler!   ( a_addr -- )   gforth  does_handler_store  does-handler!   ( a_addr -- )   gforth  does_handler_store
 ""Create a @code{DOES>}-handler at address @i{a-addr}. Usually, @i{a-addr} points  ""Create a @code{DOES>}-handler at address @i{a-addr}. Normally,
 just behind a @code{DOES>}.""  @i{a-addr} points just behind a @code{DOES>}.""
 MAKE_DOES_HANDLER(a_addr);  MAKE_DOES_HANDLER(a_addr);
 CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE);  CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE);
 :  :
Line 1584  access the stack itself. The stack point Line 1584  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 1647  if (wior) Line 1647  if (wior)
   clearerr((FILE *)wfileid);    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 1  ""this is only for backward compatibility""
 Cell c;  Cell c;
 flag=-1;  flag=-1;
 for(u2=0; u2<u1; u2++)  for(u2=0; u2<u1; u2++)
Line 1666  for(u2=0; u2<u1; u2++) Line 1666  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 1906  number[u]='\0'; Line 1892  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 1916  else if(*endconv=='d' || *endconv=='D') Line 1902  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 2210  UP=up=(char *)a_addr; Line 2196  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 2286  dsystem = timeval2us(&usage.ru_stime); Line 2272  dsystem = timeval2us(&usage.ru_stime);
 struct timeval time1;  struct timeval time1;
 gettimeofday(&time1,NULL);  gettimeofday(&time1,NULL);
 duser = timeval2us(&time1);  duser = timeval2us(&time1);
   #ifndef BUGGY_LONG_LONG
 dsystem = (DCell)0;  dsystem = (DCell)0;
   #else
   dsystem=(DCell){0,0};
   #endif
 #endif  #endif
   
 \+  \+
Line 2320  for (; ucount>0; ucount--) { Line 2310  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.56  
changed lines
  Added in v.1.64


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