Diff for /gforth/prim between versions 1.5 and 1.10

version 1.5, 1997/07/06 14:37:00 version 1.10, 1998/07/28 12:29:37
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 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]  \+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 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]  \+has? xconds [IF]
   
 condbranch((-loop),u --         gforth  paren_minus_loop,  condbranch((-loop),u --         gforth  paren_minus_loop,
 /* !! check this thoroughly */  /* !! check this thoroughly */
Line 325  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 905  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 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-floats [IF]  \+has? floating [IF]
   
 fp@     -- f_addr       gforth  fp_fetch  fp@     -- f_addr       gforth  fp_fetch
 f_addr = fp;  f_addr = fp;
Line 1017  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 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]  \+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;  F83Name *f83name1;
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]  \+has? os [IF]
   
 (key)   -- n            gforth  paren_key  (key)   -- n            gforth  paren_key
 fflush(stdout);  fflush(stdout);
Line 1493  fp=FP; Line 1493  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);
Line 1574  else { Line 1574  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 1590  wior = FILEIO(putc(c, (FILE *)wfileid)== Line 1590  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 1619  else { Line 1619  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 1914  df_addr = (DFloat *)((((Cell)c_addr)+(si Line 1914  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 1932  w = *(Cell *)(lp+2*sizeof(Cell)); Line 1932  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 1974  lp = (Address)c_addr; Line 1974  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  \+[THEN]  [THEN] \ has? glocals
   
 \+has-OS [IF]  \+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 2004  define(argclist, Line 2004  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 2043  icall(20) Line 2046  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.5  
changed lines
  Added in v.1.10


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