Diff for /gforth/prim between versions 1.17 and 1.23

version 1.17, 1998/12/11 22:54:27 version 1.23, 1999/02/06 22:28:21
Line 115  INC_IP(1); Line 115  INC_IP(1);
  r> dup @ swap cell+ >r ;   r> dup @ swap cell+ >r ;
   
 execute         xt --           core  execute         xt --           core
   ""Perform the semantics represented by the execution token, xt.""
 ip=IP;  ip=IP;
 IF_TOS(TOS = sp[0]);  IF_TOS(TOS = sp[0]);
 EXEC(xt);  EXEC(xt);
   
 perform         a_addr --       gforth  perform         a_addr --       gforth
 ""equivalent to @code{@ execute}""  ""Equivalent to @code{@ execute}.""
 /* and pfe */  /* and pfe */
 ip=IP;  ip=IP;
 IF_TOS(TOS = sp[0]);  IF_TOS(TOS = sp[0]);
Line 140  goto branch; Line 141  goto branch;
   
 branch  --              gforth  branch  --              gforth
 branch:  branch:
 ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);  SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
 NEXT_P0;  
 :  :
  r> dup @ + >r ;   r> dup @ + >r ;
   
Line 149  NEXT_P0; Line 149  NEXT_P0;
 \ this is non-syntactical: code must open a brace that is closed by the macro  \ this is non-syntactical: code must open a brace that is closed by the macro
 define(condbranch,  define(condbranch,
 $1      $2  $1      $2
 $3      ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);  $3      SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
         NEXT_P0;  
         NEXT;          NEXT;
 }  }
 else  else
Line 188  if (f==0) { Line 187  if (f==0) {
 if (f==0) {  if (f==0) {
   sp++;    sp++;
   IF_TOS(TOS = sp[0]);    IF_TOS(TOS = sp[0]);
   ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);    SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
   NEXT_P0;  
   NEXT;    NEXT;
 }  }
 else  else
Line 203  few cycles in that case, but is easy to Line 201  few cycles in that case, but is easy to
 invocation */  invocation */
 if (f!=0) {  if (f!=0) {
   sp--;    sp--;
   ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);    SET_IP((Xt *)(((Cell)IP)+(Cell)NEXT_INST));
   NEXT_P0;  
   NEXT;    NEXT;
 }  }
 else  else
Line 443  n = rp[4]; Line 440  n = rp[4];
 \ digit is high-level: 0/0%  \ digit is high-level: 0/0%
   
 move    c_from c_to ucount --           core  move    c_from c_to ucount --           core
   "" If ucount>0, copy the contents of ucount address units
   at c-from to c-to. @code{move} chooses its copy direction
   to avoid problems when c-from, c-to overlap.""
 memmove(c_to,c_from,ucount);  memmove(c_to,c_from,ucount);
 /* make an Ifdef for bsd and others? */  /* make an Ifdef for bsd and others? */
 :  :
  >r 2dup u< IF r> cmove> ELSE r> cmove THEN ;   >r 2dup u< IF r> cmove> ELSE r> cmove THEN ;
   
 cmove   c_from c_to u --        string  cmove   c_from c_to u --        string
   "" If u>0, copy the contents of ucount characters from
   data space at c-from to c-to. The copy proceeds @code{char}-by-@code{char}
   from low address to high address.""
 while (u-- > 0)  while (u-- > 0)
   *c_to++ = *c_from++;    *c_to++ = *c_from++;
 :  :
  bounds ?DO  dup c@ I c! 1+  LOOP  drop ;   bounds ?DO  dup c@ I c! 1+  LOOP  drop ;
   
 cmove>  c_from c_to u --        string  c_move_up  cmove>  c_from c_to u --        string  c_move_up
   "" If u>0, copy the contents of ucount characters from
   data space at c-from to c-to. The copy proceeds @code{char}-by-@code{char}
   from high address to low address.""
 while (u-- > 0)  while (u-- > 0)
   c_to[u] = c_from[u];    c_to[u] = c_from[u];
 :  :
Line 463  while (u-- > 0) Line 469  while (u-- > 0)
  DO  1- dup c@ I c!  -1 +LOOP  drop ;   DO  1- dup c@ I c!  -1 +LOOP  drop ;
   
 fill    c_addr u c --   core  fill    c_addr u c --   core
   "" If u>0, store character c in each of u consecutive
   @code{char} addresses in memory, starting at address c-addr.""
 memset(c_addr,c,u);  memset(c_addr,c,u);
 :  :
  -rot bounds   -rot bounds
  ?DO  dup I c!  LOOP  drop ;   ?DO  dup I c!  LOOP  drop ;
   
 compare         c_addr1 u1 c_addr2 u2 -- n      string  compare         c_addr1 u1 c_addr2 u2 -- n      string
 ""Compare the strings lexicographically. If they are equal, n is 0; if  ""Compare two strings lexicographically. If they are equal, n is 0; if
 the first string is smaller, n is -1; if the first string is larger, n  the first string is smaller, n is -1; if the first string is larger, n
 is 1. Currently this is based on the machine's character  is 1. Currently this is based on the machine's character
 comparison. In the future, this may change to considering the current  comparison. In the future, this may change to considering the current
Line 942  fp = f_addr; Line 950  fp = f_addr;
 \+  \+
   
 ;s      --              gforth  semis  ;s      --              gforth  semis
 ip = (Xt *)(*rp++);  ""The primitive compiled by @code{EXIT}.""
 NEXT_P0;  SET_IP((Xt *)(*rp++));
   
 >r      w --            core    to_r  >r      w --            core    to_r
 *--rp = w;  *--rp = w;
Line 1171  n2 = n1 * sizeof(Char); Line 1179  n2 = n1 * sizeof(Char);
  ;   ;
   
 count   c_addr1 -- c_addr2 u    core  count   c_addr1 -- c_addr2 u    core
   "" If c-add1 is the address of a counted string return the length of
   the string, u, and the address of its first character, c-addr2.""
 u = *c_addr1;  u = *c_addr1;
 c_addr2 = c_addr1+1;  c_addr2 = c_addr1+1;
 :  :
Line 1318  c_addr = (Address)CODE_ADDRESS(xt); Line 1328  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 xt ist the execution token of a defining-word-defined word,  ""If xt ist the execution token of a defining-word-defined word,
 a_addr is the start of the Forth code after the DOES>;  a_addr is the start of the Forth code after the @code{DOES>};
 Otherwise a_addr is 0.""  Otherwise a_addr is 0.""
 a_addr = (Cell *)DOES_CODE(xt);  a_addr = (Cell *)DOES_CODE(xt);
 :  :
Line 1420  FLUSH_ICACHE(c_addr,u); Line 1430  FLUSH_ICACHE(c_addr,u);
 return (Label *)n;  return (Label *)n;
   
 (system)        c_addr u -- wretval wior        gforth  peren_system  (system)        c_addr u -- wretval wior        gforth  peren_system
   #ifndef MSDOS
 int old_tp=terminal_prepped;  int old_tp=terminal_prepped;
 deprep_terminal();  deprep_terminal();
   #endif
 wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */  wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */
 wior = IOR(wretval==-1 || (wretval==127 && errno != 0));  wior = IOR(wretval==-1 || (wretval==127 && errno != 0));
   #ifndef MSDOS
 if (old_tp)  if (old_tp)
   prep_terminal();    prep_terminal();
   #endif
   
 getenv  c_addr1 u1 -- c_addr2 u2        gforth  getenv  c_addr1 u1 -- c_addr2 u2        gforth
 c_addr2 = getenv(cstr(c_addr1,u1,1));  c_addr2 = getenv(cstr(c_addr1,u1,1));
Line 1509  IF_FTOS(FTOS=fp[0]); Line 1523  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 -- w2 wior       file    open_file  open-file       c_addr u ntype -- wfileid wior  file    open_file
 w2 = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]);  wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]);
 #if defined(GO32) && defined(MSDOS)  #if defined(GO32) && defined(MSDOS)
 if(w2 && !(ntype & 1))  if(wfileid && !(ntype & 1))
   setbuf((FILE*)w2, NULL);    setbuf((FILE*)wfileid, NULL);
 #endif  #endif
 wior =  IOR(w2 == 0);  wior =  IOR(wfileid == 0);
   
 create-file     c_addr u ntype -- w2 wior       file    create_file  create-file     c_addr u ntype -- 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[ntype], 0666);
 if (fd != -1) {  if (fd != -1) {
   w2 = (Cell)fdopen(fd, fileattr[ntype]);    wfileid = (Cell)fdopen(fd, fileattr[ntype]);
 #if defined(GO32) && defined(MSDOS)  #if defined(GO32) && defined(MSDOS)
   if(w2 && !(ntype & 1))    if(wfileid && !(ntype & 1))
     setbuf((FILE*)w2, NULL);      setbuf((FILE*)wfileid, NULL);
 #endif  #endif
   wior = IOR(w2 == 0);    wior = IOR(wfileid == 0);
 } else {  } else {
   w2 = 0;    wfileid = 0;
   wior = IOR(1);    wior = IOR(1);
 }  }
   
Line 1536  delete-file c_addr u -- wior  file delet Line 1550  delete-file c_addr u -- wior  file delet
 wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1);  wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1);
   
 rename-file     c_addr1 u1 c_addr2 u2 -- wior   file-ext        rename_file  rename-file     c_addr1 u1 c_addr2 u2 -- wior   file-ext        rename_file
   ""rename file c_addr1 u1 to new name c_addr2 u2""
 char *s1=tilde_cstr(c_addr2, u2, 1);  char *s1=tilde_cstr(c_addr2, u2, 1);
 wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);  wior = IOR(rename(tilde_cstr(c_addr1, u1, 0), s1)==-1);
   
Line 1660  r = d; Line 1675  r = d;
   
 f>d             r -- d          float   f_to_d  f>d             r -- d          float   f_to_d
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 d.hi = ldexp(r,-CELL_BITS) - (r<0);  d.hi = ldexp(r,-(int)(CELL_BITS)) - (r<0);
 d.lo = r-ldexp((Float)d.hi,CELL_BITS);  d.lo = r-ldexp((Float)d.hi,CELL_BITS);
 #else  #else
 d = r;  d = r;
Line 1773  int decpt; Line 1788  int decpt;
 sig=ecvt(r, u, &decpt, &flag);  sig=ecvt(r, u, &decpt, &flag);
 n=(r==0 ? 1 : decpt);  n=(r==0 ? 1 : decpt);
 f1=FLAG(flag!=0);  f1=FLAG(flag!=0);
 f2=FLAG(isdigit(sig[0])!=0);  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
Line 1781  memmove(c_addr,sig,u); Line 1796  memmove(c_addr,sig,u);
 Float r;  Float r;
 char *number=cstr(c_addr, u, 1);  char *number=cstr(c_addr, u, 1);
 char *endconv;  char *endconv;
 while(isspace(number[--u]) && u>0);  while(isspace((unsigned)(number[--u])) && u>0);
 switch(number[u])  switch(number[u])
 {  {
    case 'd':     case 'd':
Line 2054  open-lib c_addr1 u1 -- u2 gforth open_li Line 2069  open-lib c_addr1 u1 -- u2 gforth open_li
 #endif  #endif
 u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);  u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);
 #else  #else
 #  ifdef HAVE_LIBKERNEL32  #  ifdef _WIN32
 u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));  u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));
 #  else  #  else
 #warning Define open-lib!  #warning Define open-lib!
Line 2066  lib-sym c_addr1 u1 u2 -- u3 gforth lib_s Line 2081  lib-sym c_addr1 u1 u2 -- u3 gforth lib_s
 #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)  #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
 u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1));  u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1));
 #else  #else
 #  ifdef HAVE_LIBKERNEL32  #  ifdef _WIN32
 u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1));  u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1));
 #  else  #  else
 #warning Define lib-sym!  #warning Define lib-sym!

Removed from v.1.17  
changed lines
  Added in v.1.23


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