Diff for /gforth/prim between versions 1.2 and 1.14

version 1.2, 1997/06/06 17:27:57 version 1.14, 1998/11/08 23:08:04
Line 128  EXEC(*(Xt *)a_addr); Line 128  EXEC(*(Xt *)a_addr);
 :  :
  @ execute ;   @ execute ;
   
 \+has-locals [IF]  \+has? glocals [IF]
   
 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 */
Line 157  else Line 157  else
     INC_IP(1);      INC_IP(1);
 $4  $4
   
 \+has-locals [IF]  \+has? glocals [IF]
   
 $1-lp+!#        $2_lp_plus_store_number  $1-lp+!#        $2_lp_plus_store_number
 $3    goto branch_adjust_lp;  $3    goto branch_adjust_lp;
Line 171  else Line 171  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_TOS(TOS = sp[0]);
 ,)  ,:
    0= dup     \ !f !f
    r> dup @   \ !f !f IP branchoffset
    rot and +  \ !f IP|IP+branchoffset
    swap 0= cell and + \ IP''
    >r ;)
   
 \ we don't need an lp_plus_store version of the ?dup-stuff, because it  \ we don't need an lp_plus_store version of the ?dup-stuff, because it
 \ is only used in if's (yet)  \ is only used in if's (yet)
   
 \+has-xconds [IF]  \+has? xconds [IF]
   
 ?dup-?branch    f -- f  new     question_dupe_question_branch  ?dup-?branch    f -- f  new     question_dupe_question_branch
 ""The run-time procedure compiled by @code{?DUP-IF}.""  ""The run-time procedure compiled by @code{?DUP-IF}.""
Line 245  if ((olddiff^(olddiff+n))>=0   /* the li Line 250  if ((olddiff^(olddiff+n))>=0   /* the li
  IF    >r + >r dup @ + >r   IF    >r + >r dup @ + >r
  ELSE  >r >r drop cell+ >r THEN ;)   ELSE  >r >r drop cell+ >r THEN ;)
   
 \+has-xconds [IF]  \+has? xconds [IF]
   
 condbranch((-loop),u --         gforth  paren_minus_loop,  condbranch((-loop),u --         gforth  paren_minus_loop,
 /* !! check this thoroughly */  /* !! check this thoroughly */
Line 320  else { Line 325  else {
        cell+ >r         cell+ >r
   THEN ;                                \ --> CORE-EXT    THEN ;                                \ --> CORE-EXT
   
 \+has-xconds [IF]  \+has? xconds [IF]
   
 (+do)   nlimit nstart --        gforth  paren_plus_do  (+do)   nlimit nstart --        gforth  paren_plus_do
 *--rp = nlimit;  *--rp = nlimit;
Line 404  else { Line 409  else {
   
 \+[THEN]  \+[THEN]
   
   \ don't make any assumptions where the return stack is!!
   \ implement this in machine code if it should run quickly!
   
 i       -- n            core  i       -- n            core
 n = *rp;  n = *rp;
 :  :
  rp@ cell+ @ ;  \ rp@ cell+ @ ;
     r> r> tuck >r >r ;
   
 i'      -- w            gforth          i_tick  i'      -- w            gforth          i_tick
 ""loop end value""  ""loop end value""
 w = rp[1];  w = rp[1];
 :  :
  rp@ cell+ cell+ @ ;  \ rp@ cell+ cell+ @ ;
     r> r> r> dup itmp ! >r >r >r itmp @ ;
   variable itmp
   
 j       -- n            core  j       -- n            core
 n = rp[2];  n = rp[2];
 :  :
  rp@ cell+ cell+ cell+ @ ;  \ rp@ cell+ cell+ cell+ @ ;
     r> r> r> r> dup itmp ! >r >r >r >r itmp @ ;
   [IFUNDEF] itmp variable itmp [THEN]
   
 k       -- n            gforth  k       -- n            gforth
 n = rp[4];  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 @ ;
   [IFUNDEF] itmp variable itmp [THEN]
   
 \ digit is high-level: 0/0%  \ digit is high-level: 0/0%
   
Line 508  else if (n>0) Line 523  else if (n>0)
   
 -trailing       c_addr u1 -- c_addr u2          string  dash_trailing  -trailing       c_addr u1 -- c_addr u2          string  dash_trailing
 u2 = u1;  u2 = u1;
  while (u2>0 && c_addr[u2-1] == ' ')  while (u2>0 && c_addr[u2-1] == ' ')
   u2--;    u2--;
 :  :
  BEGIN  1- 2dup + c@ bl =  WHILE   BEGIN  1- 2dup + c@ bl =  WHILE
Line 607  n2 = n1>>1; Line 622  n2 = n1>>1;
 :  :
  dup MINI and IF 1 ELSE 0 THEN   dup MINI and IF 1 ELSE 0 THEN
  [ bits/byte cell * 1- ] literal    [ bits/byte cell * 1- ] literal 
  0 DO 2* swap dup 2* >r U-HIGHBIT and    0 DO 2* swap dup 2* >r MINI and 
      IF 1 ELSE 0 THEN or r> swap       IF 1 ELSE 0 THEN or r> swap
  LOOP nip ;   LOOP nip ;
   
Line 694  u2 = ud%u1; Line 709  u2 = ud%u1;
 #endif  #endif
 :  :
    0 swap [ 8 cells 1 + ] literal 0     0 swap [ 8 cells 1 + ] literal 0
    ?DO >r /modstep r>      ?DO /modstep
    LOOP drop swap 1 rshift or swap ;     LOOP drop swap 1 rshift or swap ;
 : /modstep ( ud c R: u -- ud-?u c R: u )  : /modstep ( ud c R: u -- ud-?u c R: u )
    over I' u< 0= or IF I' - 1 ELSE 0 THEN  d2*+ ;     >r over r@ u< 0= or IF r@ - 1 ELSE 0 THEN  d2*+ r> ;
 : d2*+ ( ud n -- ud+n c )  : d2*+ ( ud n -- ud+n c )
    over MINI     over MINI
    and >r >r 2dup d+ swap r> + swap r> ;     and >r >r 2dup d+ swap r> + swap r> ;
Line 890  f = FLAG($4>=$5); Line 905  f = FLAG($4>=$5);
   
 )  )
   
 \+has-dcomps [IF]  \+has? dcomps [IF]
   
 dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth)  dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth)
 dcomparisons(d0, d, d_zero_, d, DZERO, double, gforth, double, gforth)  dcomparisons(d0, d, d_zero_, d, DZERO, double, gforth, double, gforth)
Line 916  a_addr = rp; Line 931  a_addr = rp;
 rp!     a_addr --               gforth          rpstore  rp!     a_addr --               gforth          rpstore
 rp = a_addr;  rp = a_addr;
   
 \+has-floats [IF]  \+has? floating [IF]
   
 fp@     -- f_addr       gforth  fp_fetch  fp@     -- f_addr       gforth  fp_fetch
 f_addr = fp;  f_addr = fp;
Line 1002  Variable (rot) Line 1017  Variable (rot)
   
 nip     w1 w2 -- w2             core-ext  nip     w1 w2 -- w2             core-ext
 :  :
  >r drop r> ;   swap drop ;
   
 tuck    w1 w2 -- w2 w1 w2       core-ext  tuck    w1 w2 -- w2 w1 w2       core-ext
 :  :
Line 1162  c_addr2 = c_addr1+1; Line 1177  c_addr2 = c_addr1+1;
  dup 1+ swap c@ ;   dup 1+ swap c@ ;
   
 (f83find)       c_addr u f83name1 -- f83name2   new     paren_f83find  (f83find)       c_addr u f83name1 -- f83name2   new     paren_f83find
 for (; f83name1 != NULL; f83name1 = f83name1->next)  for (; f83name1 != NULL; f83name1 = (struct F83Name *)(f83name1->next))
   if ((UCell)F83NAME_COUNT(f83name1)==u &&    if ((UCell)F83NAME_COUNT(f83name1)==u &&
       memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)        memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
     break;      break;
Line 1176  f83name2=f83name1; Line 1191  f83name2=f83name1;
 : (find-samelen) ( u f83name1 -- u f83name2/0 )  : (find-samelen) ( u f83name1 -- u f83name2/0 )
     BEGIN  2dup cell+ c@ $1F and <> WHILE  @  dup 0= UNTIL  THEN ;      BEGIN  2dup cell+ c@ $1F and <> WHILE  @  dup 0= UNTIL  THEN ;
   
 \+has-hash [IF]  \+has? hash [IF]
   
 (hashfind)      c_addr u a_addr -- f83name2     new     paren_hashfind  (hashfind)      c_addr u a_addr -- f83name2     new     paren_hashfind
 F83Name *f83name1;  struct F83Name *f83name1;
 f83name2=NULL;  f83name2=NULL;
 while(a_addr != NULL)  while(a_addr != NULL)
 {  {
    f83name1=(F83Name *)(a_addr[1]);     f83name1=(struct F83Name *)(a_addr[1]);
    a_addr=(Cell *)(a_addr[0]);     a_addr=(Cell *)(a_addr[0]);
    if ((UCell)F83NAME_COUNT(f83name1)==u &&     if ((UCell)F83NAME_COUNT(f83name1)==u &&
        memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)         memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
Line 1202  while(a_addr != NULL) Line 1217  while(a_addr != NULL)
   
 (tablefind)     c_addr u a_addr -- f83name2     new     paren_tablefind  (tablefind)     c_addr u a_addr -- f83name2     new     paren_tablefind
 ""A case-sensitive variant of @code{(hashfind)}""  ""A case-sensitive variant of @code{(hashfind)}""
 F83Name *f83name1;  struct F83Name *f83name1;
 f83name2=NULL;  f83name2=NULL;
 while(a_addr != NULL)  while(a_addr != NULL)
 {  {
    f83name1=(F83Name *)(a_addr[1]);     f83name1=(struct F83Name *)(a_addr[1]);
    a_addr=(Cell *)(a_addr[0]);     a_addr=(Cell *)(a_addr[0]);
    if ((UCell)F83NAME_COUNT(f83name1)==u &&     if ((UCell)F83NAME_COUNT(f83name1)==u &&
        memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */)         memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
Line 1312  a_addr = (Cell *)DOES_CODE(xt); Line 1327  a_addr = (Cell *)DOES_CODE(xt);
 code-address!           c_addr xt --            gforth  code_address_store  code-address!           c_addr xt --            gforth  code_address_store
 ""Creates a code field with code address c_addr at xt""  ""Creates a code field with code address c_addr at xt""
 MAKE_CF(xt, c_addr);  MAKE_CF(xt, c_addr);
 CACHE_FLUSH(xt,PFA(0));  CACHE_FLUSH(xt,(size_t)PFA(0));
 :  :
     ! ;      ! ;
   
Line 1320  does-code! a_addr xt --  gforth does_cod Line 1335  does-code! a_addr xt --  gforth does_cod
 ""creates a code field at xt for a defining-word-defined word; a_addr  ""creates a code field at xt for a defining-word-defined word; a_addr
 is the start of the Forth code after DOES>""  is the start of the Forth code after DOES>""
 MAKE_DOES_CF(xt, a_addr);  MAKE_DOES_CF(xt, a_addr);
 CACHE_FLUSH(xt,PFA(0));  CACHE_FLUSH(xt,(size_t)PFA(0));
 :  :
     dodoes: over ! cell+ ! ;      dodoes: over ! cell+ ! ;
   
Line 1328  does-handler! a_addr -- gforth does_hand Line 1343  does-handler! a_addr -- gforth does_hand
 ""creates a DOES>-handler at address a_addr. a_addr usually points  ""creates a DOES>-handler at address a_addr. a_addr usually points
 just behind a DOES>.""  just behind a DOES>.""
 MAKE_DOES_HANDLER(a_addr);  MAKE_DOES_HANDLER(a_addr);
 CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE);  CACHE_FLUSH((caddr_t)a_addr,DOES_HANDLER_SIZE);
 :  :
     drop ;      drop ;
   
Line 1354  n=1; Line 1369  n=1;
 :  :
  1 ;   1 ;
   
 \+has-os [IF]  \+has? os [IF]
   
 (key)   -- n            gforth  paren_key  key-file        wfileid -- n            gforth  paren_key_file
 fflush(stdout);  fflush(stdout);
 /* !! noecho */  n = key((FILE*)wfileid);
 n = key();  
   
 key?    -- n            facility        key_q  key?-file       wfileid -- n            facility        key_q_file
 fflush(stdout);  fflush(stdout);
 n = key_query;  n = key_query((FILE*)wfileid);
   
   stdin   -- wfileid      gforth
   wfileid = (Cell)stdin;
   
 stdout  -- wfileid      gforth  stdout  -- wfileid      gforth
 wfileid = (Cell)stdout;  wfileid = (Cell)stdout;
Line 1478  fp=FP; Line 1495  fp=FP;
 IF_TOS(TOS=sp[0]);  IF_TOS(TOS=sp[0]);
 IF_FTOS(FTOS=fp[0]);  IF_FTOS(FTOS=fp[0]);
   
 \+[THEN] ( has-os ) has-files [IF]  \+[THEN] ( has? os ) has? file [IF]
   
 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 -- w2 wior       file    open_file
 w2 = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]);  w2 = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[ntype]);
   #if defined(GO32) && defined(MSDOS)
   if(w2 && !(ntype & 1))
     setbuf((FILE*)w2, NULL);
   #endif
 wior =  IOR(w2 == 0);  wior =  IOR(w2 == 0);
   
 create-file     c_addr u ntype -- w2 wior       file    create_file  create-file     c_addr u ntype -- w2 wior       file    create_file
Line 1492  Cell fd; Line 1513  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]);    w2 = (Cell)fdopen(fd, fileattr[ntype]);
   #if defined(GO32) && defined(MSDOS)
     if(w2 && !(ntype & 1))
       setbuf((FILE*)w2, NULL);
   #endif
   wior = IOR(w2 == 0);    wior = IOR(w2 == 0);
 } else {  } else {
   w2 = 0;    w2 = 0;
Line 1514  reposition-file ud wfileid -- wior file Line 1539  reposition-file ud wfileid -- wior file
 wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1);  wior = IOR(fseek((FILE *)wfileid, UD2LONG(ud), SEEK_SET)==-1);
   
 file-size       wfileid -- ud wior      file    file_size  file-size       wfileid -- ud wior      file    file_size
 #include <sys/stat.h>  
 struct stat buf;  struct stat buf;
 wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1);  wior = IOR(fstat(fileno((FILE *)wfileid), &buf)==-1);
 ud = LONG2UD(buf.st_size);  ud = LONG2UD(buf.st_size);
Line 1559  else { Line 1583  else {
   u2=0;    u2=0;
 }  }
   
 \+[THEN]  has-files [IF] -1 [ELSE] has-os [THEN] [IF]  \+[THEN]  has? file [IF] -1 [ELSE] has? os [THEN] [IF]
   
 write-file      c_addr u1 wfileid -- wior       file    write_file  write-file      c_addr u1 wfileid -- wior       file    write_file
 /* !! fwrite does not guarantee enough */  /* !! fwrite does not guarantee enough */
Line 1575  wior = FILEIO(putc(c, (FILE *)wfileid)== Line 1599  wior = FILEIO(putc(c, (FILE *)wfileid)==
 if (wior)  if (wior)
   clearerr((FILE *)wfileid);    clearerr((FILE *)wfileid);
   
 \+[THEN]  has-files [IF]  \+[THEN]  has? file [IF]
   
 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);
Line 1604  else { Line 1628  else {
   wior=0;    wior=0;
 }  }
   
 \+[THEN] ( has-files ) has-floats [IF]  \+[THEN] ( has? file ) has? floating [IF]
   
 comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)  comparisons(f, r1 r2, f_, r1, r2, gforth, gforth, float, gforth)
 comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth)  comparisons(f0, r, f_zero_, r, 0., float, gforth, float, gforth)
Line 1795  r2 = exp(r1); Line 1819  r2 = exp(r1);
 fexpm1          r1 -- r2        float-ext  fexpm1          r1 -- r2        float-ext
 ""@i{r2}=@i{e}**@i{r1}@minus{}1""  ""@i{r2}=@i{e}**@i{r1}@minus{}1""
 #ifdef HAVE_EXPM1  #ifdef HAVE_EXPM1
 extern double expm1(double);  extern double
   #ifdef NeXT
                 const
   #endif
                       expm1(double);
 r2 = expm1(r1);  r2 = expm1(r1);
 #else  #else
 r2 = exp(r1)-1.;  r2 = exp(r1)-1.;
Line 1807  r2 = log(r1); Line 1835  r2 = log(r1);
 flnp1           r1 -- r2        float-ext  flnp1           r1 -- r2        float-ext
 ""@i{r2}=ln(@i{r1}+1)""  ""@i{r2}=ln(@i{r1}+1)""
 #ifdef HAVE_LOG1P  #ifdef HAVE_LOG1P
 extern double log1p(double);  extern double
   #ifdef NeXT
                 const
   #endif
                       log1p(double);
 r2 = log1p(r1);  r2 = log1p(r1);
 #else  #else
 r2 = log(r1+1.);  r2 = log(r1+1.);
Line 1891  df_addr = (DFloat *)((((Cell)c_addr)+(si Line 1923  df_addr = (DFloat *)((((Cell)c_addr)+(si
 \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */  \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
   
 \ local variable implementation primitives  \ local variable implementation primitives
 \+[THEN] ( has-floats ) has-locals [IF]  \+[THEN] ( has? floats ) has? glocals [IF]
   
 @local#         -- w    gforth  fetch_local_number  @local#         -- w    gforth  fetch_local_number
 w = *(Cell *)(lp+(Cell)NEXT_INST);  w = *(Cell *)(lp+(Cell)NEXT_INST);
Line 1909  w = *(Cell *)(lp+2*sizeof(Cell)); Line 1941  w = *(Cell *)(lp+2*sizeof(Cell));
 @local3 -- w    new     fetch_local_twelve  @local3 -- w    new     fetch_local_twelve
 w = *(Cell *)(lp+3*sizeof(Cell));  w = *(Cell *)(lp+3*sizeof(Cell));
   
 \+has-floats [IF]  \+has? floating [IF]
   
 f@local#        -- r    gforth  f_fetch_local_number  f@local#        -- r    gforth  f_fetch_local_number
 r = *(Float *)(lp+(Cell)NEXT_INST);  r = *(Float *)(lp+(Cell)NEXT_INST);
Line 1951  lp = (Address)c_addr; Line 1983  lp = (Address)c_addr;
 lp -= sizeof(Cell);  lp -= sizeof(Cell);
 *(Cell *)lp = w;  *(Cell *)lp = w;
   
 \+has-floats [IF]  \+has? floating [IF]
   
 f>l     r --    gforth  f_to_l  f>l     r --    gforth  f_to_l
 lp -= sizeof(Float);  lp -= sizeof(Float);
 *(Float *)lp = r;  *(Float *)lp = r;
   
 \+[THEN]  [THEN] \ has-locals  fpick   u -- r          gforth
   r = fp[u+1]; /* +1, because update of fp happens before this fragment */
   :
    floats fp@ + f@ ;
   
 \+has-OS [IF]  \+[THEN]  [THEN] \ has? glocals
   
   \+has? OS [IF]
   
 define(`uploop',  define(`uploop',
        `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')')         `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')')
Line 1981  define(argclist, Line 2018  define(argclist,
 \ icall(argnum)  \ icall(argnum)
 define(icall,  define(icall,
 `icall$1        argflist($1)u -- uret   gforth  `icall$1        argflist($1)u -- uret   gforth
 uret = ((Cell(*)(argdlist($1)))u)(argclist($1));  uret = (SYSCALL(Cell(*)(argdlist($1)))u)(argclist($1));
   
 ')  ')
 define(fcall,  define(fcall,
 `fcall$1        argflist($1)u -- rret   gforth  `fcall$1        argflist($1)u -- rret   gforth
 rret = ((Float(*)(argdlist($1)))u)(argclist($1));  rret = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1));
   
 ')  ')
   
   
 open-lib        c_addr1 u1 -- u2        gforth  open_lib  open-lib        c_addr1 u1 -- u2        gforth  open_lib
 #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)  #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
 u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_LAZY);  #ifndef RTLD_GLOBAL
   #define RTLD_GLOBAL 0
   #endif
   u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);
 #else  #else
 #  ifdef HAVE_LIBKERNEL32  #  ifdef HAVE_LIBKERNEL32
 u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));  u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));
Line 2020  icall(20) Line 2060  icall(20)
 uploop(i, 0, 7, `fcall(i)')  uploop(i, 0, 7, `fcall(i)')
 fcall(20)  fcall(20)
   
 \+[THEN] \ has-OS  \+[THEN] \ has? OS
   
 up!     a_addr --       gforth  up_store  up!     a_addr --       gforth  up_store
 UP=up=(char *)a_addr;  UP=up=(char *)a_addr;

Removed from v.1.2  
changed lines
  Added in v.1.14


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