Diff for /gforth/prim between versions 1.53 and 1.62

version 1.53, 2000/08/11 19:49:39 version 1.62, 2000/09/23 15:06:01
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 121  IF_TOS(TOS = sp[0]); Line 121  IF_TOS(TOS = sp[0]);
 EXEC(xt);  EXEC(xt);
   
 perform ( a_addr -- )   gforth  perform ( a_addr -- )   gforth
 ""Equivalent to @code{@ execute}.""  ""@code{@@ execute}.""
 /* and pfe */  /* and pfe */
 ip=IP;  ip=IP;
 IF_TOS(TOS = sp[0]);  IF_TOS(TOS = sp[0]);
Line 1224  n2 = n1 * sizeof(Char); Line 1224  n2 = n1 * sizeof(Char);
  ;   ;
   
 count   ( c_addr1 -- c_addr2 u )        core  count   ( c_addr1 -- c_addr2 u )        core
 "" If @i{c-add1} is the address of a counted string return the length of  ""@i{c-addr2} is the first character and @i{u} the length of the
 the string, @i{u}, and the address of its first character, @i{c-addr2}.""  counted string at @i{c-addr1}.""
 u = *c_addr1;  u = *c_addr1;
 c_addr2 = c_addr1+1;  c_addr2 = c_addr1+1;
 :  :
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 1504  in length."" Line 1504  in length.""
 c_addr2 = getenv(cstr(c_addr1,u1,1));  c_addr2 = getenv(cstr(c_addr1,u1,1));
 u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));  u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));
   
 open-pipe       ( c_addr u ntype -- wfileid wior )      gforth  open_pipe  open-pipe       ( c_addr u wfam -- wfileid wior )       gforth  open_pipe
 wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[ntype]); /* ~ expansion of 1st arg? */  wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[wfam]); /* ~ expansion of 1st arg? */
 wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */  wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */
   
 close-pipe      ( wfileid -- wretval wior )             gforth  close_pipe  close-pipe      ( wfileid -- wretval wior )             gforth  close_pipe
Line 1599  IF_FTOS(FTOS=fp[0]); Line 1599  IF_FTOS(FTOS=fp[0]);
 close-file      ( wfileid -- wior )             file    close_file  close-file      ( wfileid -- wior )             file    close_file
 wior = IOR(fclose((FILE *)wfileid)==EOF);  wior = IOR(fclose((FILE *)wfileid)==EOF);
   
 open-file       ( c_addr u ntype -- wfileid wior )      file    open_file  open-file       ( c_addr u wfam -- wfileid wior )       file    open_file
 wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]);  wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[wfam]);
 wior =  IOR(wfileid == 0);  wior =  IOR(wfileid == 0);
   
 create-file     ( c_addr u ntype -- wfileid wior )      file    create_file  create-file     ( c_addr u wfam -- wfileid wior )       file    create_file
 Cell    fd;  Cell    fd;
 fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[ntype], 0666);  fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[wfam], 0666);
 if (fd != -1) {  if (fd != -1) {
   wfileid = (Cell)fdopen(fd, fileattr[ntype]);    wfileid = (Cell)fdopen(fd, fileattr[wfam]);
   wior = IOR(wfileid == 0);    wior = IOR(wfileid == 0);
 } else {  } else {
   wfileid = 0;    wfileid = 0;
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 1710  PUTC(c); Line 1696  PUTC(c);
 flush-file      ( wfileid -- wior )             file-ext        flush_file  flush-file      ( wfileid -- wior )             file-ext        flush_file
 wior = IOR(fflush((FILE *) wfileid)==EOF);  wior = IOR(fflush((FILE *) wfileid)==EOF);
   
 file-status     ( c_addr u -- ntype wior )      file-ext        file_status  file-status     ( c_addr u -- wfam wior )       file-ext        file_status
 char *filename=tilde_cstr(c_addr, u, 1);  char *filename=tilde_cstr(c_addr, u, 1);
 if (access (filename, F_OK) != 0) {  if (access (filename, F_OK) != 0) {
   ntype=0;    wfam=0;
   wior=IOR(1);    wior=IOR(1);
 }  }
 else if (access (filename, R_OK | W_OK) == 0) {  else if (access (filename, R_OK | W_OK) == 0) {
   ntype=2; /* r/w */    wfam=2; /* r/w */
   wior=0;    wior=0;
 }  }
 else if (access (filename, R_OK) == 0) {  else if (access (filename, R_OK) == 0) {
   ntype=0; /* r/o */    wfam=0; /* r/o */
   wior=0;    wior=0;
 }  }
 else if (access (filename, W_OK) == 0) {  else if (access (filename, W_OK) == 0) {
   ntype=4; /* w/o */    wfam=4; /* w/o */
   wior=0;    wior=0;
 }  }
 else {  else {
   ntype=1; /* well, we cannot access the file, but better deliver a legal    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. */              access mode (r/o bin), so we get a decent error later upon open. */
   wior=0;    wior=0;
 }  }
Line 1877  f2=FLAG(isdigit((unsigned)(sig[0]))!=0); Line 1863  f2=FLAG(isdigit((unsigned)(sig[0]))!=0);
 memmove(c_addr,sig,u);  memmove(c_addr,sig,u);
   
 >float  ( c_addr u -- flag )    float   to_float  >float  ( c_addr u -- flag )    float   to_float
 ""Attempt to convert the character string @i{c-addr u} to  ""Actual stack effect: ( c_addr u -- r t | f ).  Attempt to convert the
 internal floating-point representation. If the string  character string @i{c-addr u} to internal floating-point
 represents a valid floating-point number @i{r} is placed  representation. If the string represents a valid floating-point number
 on the floating-point stack and @i{flag} is true. Otherwise,  @i{r} is placed on the floating-point stack and @i{flag} is
 @i{flag} is false. A string of blanks is a special case  true. Otherwise, @i{flag} is false. A string of blanks is a special
 and represents the floating-point number 0.""  case and represents the floating-point number 0.""
 /* real signature: c_addr u -- r t / f */  /* real signature: c_addr u -- r t / f */
 Float r;  Float r;
 char *number=cstr(c_addr, u, 1);  char *number=cstr(c_addr, u, 1);
Line 2261  c_addr=newline; Line 2247  c_addr=newline;
 u=sizeof(newline);  u=sizeof(newline);
 :  :
  "newline count ;   "newline count ;
 Create "newline 1 c, $0A c,  Create "newline e? crlf [IF] 2 c, $0D c, [ELSE] 1 c, [THEN] $0A c,
   
   \+os
   
 utime   ( -- dtime )    gforth  utime   ( -- dtime )    gforth
 ""Report the current time in microseconds since some epoch.""  ""Report the current time in microseconds since some epoch.""
Line 2284  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
   
   \+
   
   \+floating
   
 v*      ( f_addr1 nstride1 f_addr2 nstride2 ucount -- r ) gforth v_star  v*      ( f_addr1 nstride1 f_addr2 nstride2 ucount -- r ) gforth v_star
 ""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
Line 2296  for (r=0.; ucount>0; ucount--) { Line 2292  for (r=0.; ucount>0; ucount--) {
   f_addr1 = (Float *)(((Address)f_addr1)+nstride1);    f_addr1 = (Float *)(((Address)f_addr1)+nstride1);
   f_addr2 = (Float *)(((Address)f_addr2)+nstride2);    f_addr2 = (Float *)(((Address)f_addr2)+nstride2);
 }  }
   :
    >r swap 2swap swap 0e r> 0 ?DO
        dup f@ over + 2swap dup f@ f* f+ over + 2swap
    LOOP 2drop 2drop ; 
   
 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""
Line 2304  for (; ucount>0; ucount--) { Line 2304  for (; ucount>0; ucount--) {
   f_x = (Float *)(((Address)f_x)+nstridex);    f_x = (Float *)(((Address)f_x)+nstridex);
   f_y = (Float *)(((Address)f_y)+nstridey);    f_y = (Float *)(((Address)f_y)+nstridey);
 }  }
   :
    >r swap 2swap swap r> 0 ?DO
        fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap
    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.53  
changed lines
  Added in v.1.62


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