Diff for /gforth/prim between versions 1.52 and 1.60

version 1.52, 2000/08/09 20:04:06 version 1.60, 2000/09/10 19:50:33
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 819  w2 = ~w1; Line 819  w2 = ~w1;
  MAXU xor ;   MAXU xor ;
   
 rshift  ( u1 n -- u2 )          core    r_shift  rshift  ( u1 n -- u2 )          core    r_shift
   ""Logical shift right by @i{n} bits.""
   u2 = u1>>n;    u2 = u1>>n;
 :  :
     0 ?DO 2/ MAXI and LOOP ;      0 ?DO 2/ MAXI and LOOP ;
Line 1223  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 1378  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 1393  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 1503  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 1598  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 1646  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
   ""this is only for backward compatibility""
 #if 1  #if 1
 Cell c;  Cell c;
 flag=-1;  flag=-1;
Line 1709  PUTC(c); Line 1711  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 1876  f2=FLAG(isdigit((unsigned)(sig[0]))!=0); Line 1878  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 2260  c_addr=newline; Line 2262  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 2283  dsystem = timeval2us(&usage.ru_stime); Line 2287  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
 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
Line 2295  for (r=0.; ucount>0; ucount--) { Line 2307  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 2303  for (; ucount>0; ucount--) { Line 2319  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.52  
changed lines
  Added in v.1.60


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