Diff for /gforth/prim between versions 1.9 and 1.19

version 1.9, 1998/07/05 20:50:00 version 1.19, 1998/12/13 23:29:59
Line 1 Line 1
 \ Gforth primitives  \ Gforth primitives
   
 \ Copyright (C) 1995,1996 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 128  EXEC(*(Xt *)a_addr); Line 128  EXEC(*(Xt *)a_addr);
 :  :
  @ execute ;   @ execute ;
   
 \+has? glocals [IF]  \+glocals
   
 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 136  branch_adjust_lp: Line 136  branch_adjust_lp:
 lp += (Cell)(IP[1]);  lp += (Cell)(IP[1]);
 goto branch;  goto branch;
   
 \+[THEN]  \+
   
 branch  --              gforth  branch  --              gforth
 branch:  branch:
Line 157  else Line 157  else
     INC_IP(1);      INC_IP(1);
 $4  $4
   
 \+has? glocals [IF]  \+glocals
   
 $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 165  $3    goto branch_adjust_lp; Line 165  $3    goto branch_adjust_lp;
 else  else
     INC_IP(2);      INC_IP(2);
   
 \+[THEN]  \+
 )  )
   
 condbranch(?branch,f --         f83     question_branch,  condbranch(?branch,f --         f83     question_branch,
Line 181  if (f==0) { Line 181  if (f==0) {
 \ 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]  \+xconds
   
 ?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 210  if (f!=0) { Line 210  if (f!=0) {
 else  else
   INC_IP(1);    INC_IP(1);
   
 \+[THEN]  \+
   
 condbranch((next),--            cmFORTH paren_next,  condbranch((next),--            cmFORTH paren_next,
 if ((*rp)--) {  if ((*rp)--) {
Line 250  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]  \+xconds
   
 condbranch((-loop),u --         gforth  paren_minus_loop,  condbranch((-loop),u --         gforth  paren_minus_loop,
 /* !! check this thoroughly */  /* !! check this thoroughly */
Line 286  if (diff>=0 || newdiff<0) { Line 286  if (diff>=0 || newdiff<0) {
     IF_TOS(TOS = sp[0]);      IF_TOS(TOS = sp[0]);
 ,)  ,)
   
 \+[THEN]  \+
   
 unloop          --      core  unloop          --      core
 rp += 2;  rp += 2;
Line 325  else { Line 325  else {
        cell+ >r         cell+ >r
   THEN ;                                \ --> CORE-EXT    THEN ;                                \ --> CORE-EXT
   
 \+has? xconds [IF]  \+xconds
   
 (+do)   nlimit nstart --        gforth  paren_plus_do  (+do)   nlimit nstart --        gforth  paren_plus_do
 *--rp = nlimit;  *--rp = nlimit;
Line 407  else { Line 407  else {
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
 \+[THEN]  \+
   
 \ don't make any assumptions where the return stack is!!  \ don't make any assumptions where the return stack is!!
 \ implement this in machine code if it should run quickly!  \ implement this in machine code if it should run quickly!
Line 905  f = FLAG($4>=$5); Line 905  f = FLAG($4>=$5);
   
 )  )
   
 \+has? dcomps [IF]  \+dcomps
   
 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)
 dcomparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth)  dcomparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth)
   
 \+[THEN]  \+
   
 within  u1 u2 u3 -- f           core-ext  within  u1 u2 u3 -- f           core-ext
 f = FLAG(u1-u2 < u3-u2);  f = FLAG(u1-u2 < u3-u2);
Line 931  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? floating [IF]  \+floating
   
 fp@     -- f_addr       gforth  fp_fetch  fp@     -- f_addr       gforth  fp_fetch
 f_addr = fp;  f_addr = fp;
Line 939  f_addr = fp; Line 939  f_addr = fp;
 fp!     f_addr --       gforth  fp_store  fp!     f_addr --       gforth  fp_store
 fp = f_addr;  fp = f_addr;
   
 \+[THEN]  \+
   
 ;s      --              gforth  semis  ;s      --              gforth  semis
 ip = (Xt *)(*rp++);  ip = (Xt *)(*rp++);
Line 1177  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 1191  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]  \+hash
   
 (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 1217  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 1272  Create rot-values Line 1272  Create rot-values
   7 c, 5 c, 5 c, 5 c, 5 c,  6 c, 5 c, 5 c, 5 c, 5 c,    7 c, 5 c, 5 c, 5 c, 5 c,  6 c, 5 c, 5 c, 5 c, 5 c,
   7 c, 5 c, 5 c,    7 c, 5 c, 5 c,
   
 \+[THEN]  \+
   
 (parse-white)   c_addr1 u1 -- c_addr2 u2        gforth  paren_parse_white  (parse-white)   c_addr1 u1 -- c_addr2 u2        gforth  paren_parse_white
 /* use !isgraph instead of isspace? */  /* use !isgraph instead of isspace? */
Line 1327  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 1335  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 1343  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 1369  n=1; Line 1369  n=1;
 :  :
  1 ;   1 ;
   
 \+has? os [IF]  key-file        wfileid -- n            gforth  paren_key_file
   #ifdef HAS_FILE
 (key)   -- n            gforth  paren_key  
 fflush(stdout);  fflush(stdout);
 /* !! noecho */  n = key((FILE*)wfileid);
 n = key();  #else
   n = key(stdin);
   #endif
   
 key?    -- n            facility        key_q  key?-file       wfileid -- n            facility        key_q_file
   #ifdef HAS_FILE
 fflush(stdout);  fflush(stdout);
 n = key_query;  n = key_query((FILE*)wfileid);
   #else
   n = key_query(stdin);
   #endif
   
   \+os
   
   stdin   -- wfileid      gforth
   wfileid = (Cell)stdin;
   
 stdout  -- wfileid      gforth  stdout  -- wfileid      gforth
 wfileid = (Cell)stdout;  wfileid = (Cell)stdout;
Line 1493  fp=FP; Line 1503  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? file [IF]  \+
   \+file
   
 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 1507  Cell fd; Line 1522  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 1517  delete-file c_addr u -- wior  file delet Line 1536  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 1529  reposition-file ud wfileid -- wior file Line 1549  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 1574  else { Line 1593  else {
   u2=0;    u2=0;
 }  }
   
 \+[THEN]  has? file [IF] -1 [ELSE] has? os [THEN] [IF]  \+
   \+file
   
 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 1585  write-file c_addr u1 wfileid -- wior fil Line 1605  write-file c_addr u1 wfileid -- wior fil
     clearerr((FILE *)wfileid);      clearerr((FILE *)wfileid);
 }  }
   
   \+
   
 emit-file       c wfileid -- wior       gforth  emit_file  emit-file       c wfileid -- wior       gforth  emit_file
   #ifdef HAS_FILE
 wior = FILEIO(putc(c, (FILE *)wfileid)==EOF);  wior = FILEIO(putc(c, (FILE *)wfileid)==EOF);
 if (wior)  if (wior)
   clearerr((FILE *)wfileid);    clearerr((FILE *)wfileid);
   #else
   putc(c, stdout);
   #endif
   
 \+[THEN]  has? file [IF]  \+file
   
 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 1619  else { Line 1645  else {
   wior=0;    wior=0;
 }  }
   
 \+[THEN] ( has? file ) has? floating [IF]  \+
   \+floating
   
 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 1914  df_addr = (DFloat *)((((Cell)c_addr)+(si Line 1941  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? glocals [IF]  \+
   \+glocals
   
 @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 1932  w = *(Cell *)(lp+2*sizeof(Cell)); Line 1960  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? floating [IF]  \+floating
   
 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 1944  r = *(Float *)(lp+0*sizeof(Float)); Line 1972  r = *(Float *)(lp+0*sizeof(Float));
 f@local1        -- r    new     f_fetch_local_eight  f@local1        -- r    new     f_fetch_local_eight
 r = *(Float *)(lp+1*sizeof(Float));  r = *(Float *)(lp+1*sizeof(Float));
   
 \+[THEN]  \+
   
 laddr#          -- c_addr       gforth  laddr_number  laddr#          -- c_addr       gforth  laddr_number
 /* this can also be used to implement lp@ */  /* this can also be used to implement lp@ */
Line 1974  lp = (Address)c_addr; Line 2002  lp = (Address)c_addr;
 lp -= sizeof(Cell);  lp -= sizeof(Cell);
 *(Cell *)lp = w;  *(Cell *)lp = w;
   
 \+has? floating [IF]  \+floating
   
 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? glocals  fpick   u -- r          gforth
   r = fp[u+1]; /* +1, because update of fp happens before this fragment */
   :
    floats fp@ + f@ ;
   
   \+
   \+
   
 \+has? OS [IF]  \+OS
   
 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 2021  open-lib c_addr1 u1 -- u2 gforth open_li Line 2055  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 2033  lib-sym c_addr1 u1 u2 -- u3 gforth lib_s Line 2067  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!
Line 2046  icall(20) Line 2080  icall(20)
 uploop(i, 0, 7, `fcall(i)')  uploop(i, 0, 7, `fcall(i)')
 fcall(20)  fcall(20)
   
 \+[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;
 :  :
  up ! ;   up ! ;
 Variable UP  Variable UP
   

Removed from v.1.9  
changed lines
  Added in v.1.19


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