Diff for /gforth/prim between versions 1.13 and 1.24

version 1.13, 1998/10/25 23:15:46 version 1.24, 1999/02/16 06:32:30
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 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 128  EXEC(*(Xt *)a_addr); Line 129  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 137  branch_adjust_lp:
 lp += (Cell)(IP[1]);  lp += (Cell)(IP[1]);
 goto branch;  goto branch;
   
 \+[THEN]  \+
   
 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
     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 164  $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 180  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}.""
 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
   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 247  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 283  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 322  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 404  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 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 504  else if (n>0) Line 512  else if (n>0)
  dup 0< IF  drop -1  ELSE  0>  1 and  THEN  ;   dup 0< IF  drop -1  ELSE  0>  1 and  THEN  ;
   
 toupper c1 -- c2        gforth  toupper c1 -- c2        gforth
   ""For a character a-z, convert to the equivalent upper-case
   character. All other characters are unchanged.""
 c2 = toupper(c1);  c2 = toupper(c1);
 :  :
  dup [char] a - [ char z char a - 1 + ] Literal u<  bl and - ;   dup [char] a - [ char z char a - 1 + ] Literal u<  bl and - ;
Line 905  f = FLAG($4>=$5); Line 915  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 941  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 949  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++);  ""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 1181  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 1191  f83name2=f83name1; Line 1203  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
 struct F83Name *f83name1;  struct F83Name *f83name1;
Line 1272  Create rot-values Line 1284  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 1318  c_addr = (Address)CODE_ADDRESS(xt); Line 1330  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 1369  n=1; Line 1381  n=1;
 :  :
  1 ;   1 ;
   
 \+has? os [IF]  
   
 key-file        wfileid -- n            gforth  paren_key_file  key-file        wfileid -- n            gforth  paren_key_file
   #ifdef HAS_FILE
 fflush(stdout);  fflush(stdout);
 n = key((FILE*)wfileid);  n = key((FILE*)wfileid);
   #else
   n = key(stdin);
   #endif
   
 key?-file       wfileid -- n            facility        key_q_file  key?-file       wfileid -- n            facility        key_q_file
   #ifdef HAS_FILE
 fflush(stdout);  fflush(stdout);
 n = key_query((FILE*)wfileid);  n = key_query((FILE*)wfileid);
   #else
   n = key_query(stdin);
   #endif
   
   \+os
   
 stdin   -- wfileid      gforth  stdin   -- wfileid      gforth
 wfileid = (Cell)stdin;  wfileid = (Cell)stdin;
Line 1412  FLUSH_ICACHE(c_addr,u); Line 1432  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
   ""The string c-addr1 u1 specifies an environment variable. The string c-addr2 u2
   is the host operating system's expansion of that environment variable. If the
   environment variable does not exist, c-addr2 u2 specifies a string 0 characters
   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));
   
Line 1495  fp=FP; Line 1523  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 -- 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]);
 wior =  IOR(w2 == 0);  #if defined(GO32) && defined(MSDOS)
   if(wfileid && !(ntype & 1))
     setbuf((FILE*)wfileid, NULL);
   #endif
   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]);
   wior = IOR(w2 == 0);  #if defined(GO32) && defined(MSDOS)
     if(wfileid && !(ntype & 1))
       setbuf((FILE*)wfileid, NULL);
   #endif
     wior = IOR(wfileid == 0);
 } else {  } else {
   w2 = 0;    wfileid = 0;
   wior = IOR(1);    wior = IOR(1);
 }  }
   
Line 1519  delete-file c_addr u -- wior  file delet Line 1556  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 1575  else { Line 1613  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 1586  write-file c_addr u1 wfileid -- wior fil Line 1625  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 1620  else { Line 1665  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 1635  r = d; Line 1681  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 1748  int decpt; Line 1794  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 1756  memmove(c_addr,sig,u); Line 1802  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 1915  df_addr = (DFloat *)((((Cell)c_addr)+(si Line 1961  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 1933  w = *(Cell *)(lp+2*sizeof(Cell)); Line 1980  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 1945  r = *(Float *)(lp+0*sizeof(Float)); Line 1992  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 1975  lp = (Address)c_addr; Line 2022  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);
Line 1986  r = fp[u+1]; /* +1, because update of fp Line 2033  r = fp[u+1]; /* +1, because update of fp
 :  :
  floats fp@ + f@ ;   floats fp@ + f@ ;
   
 \+[THEN]  [THEN] \ has? glocals  \+
   \+
   
 \+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 2027  open-lib c_addr1 u1 -- u2 gforth open_li Line 2075  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 2039  lib-sym c_addr1 u1 u2 -- u3 gforth lib_s Line 2087  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 2052  icall(20) Line 2100  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.13  
changed lines
  Added in v.1.24


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