Diff for /gforth/prim between versions 1.213 and 1.273

version 1.213, 2007/06/01 18:40:20 version 1.273, 2012/07/15 12:03:07
Line 1 Line 1
 \ Gforth primitives  \ Gforth primitives
   
 \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008,2009,2010,2011 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
 \ Gforth is free software; you can redistribute it and/or  \ Gforth is free software; you can redistribute it and/or
 \ modify it under the terms of the GNU General Public License  \ modify it under the terms of the GNU General Public License
 \ as published by the Free Software Foundation; either version 2  \ as published by the Free Software Foundation, either version 3
 \ of the License, or (at your option) any later version.  \ of the License, or (at your option) any later version.
   
 \ This program is distributed in the hope that it will be useful,  \ This program is distributed in the hope that it will be useful,
Line 15 Line 15
 \ GNU General Public License for more details.  \ GNU General Public License for more details.
   
 \ You should have received a copy of the GNU General Public License  \ You should have received a copy of the GNU General Public License
 \ along with this program; if not, write to the Free Software  \ along with this program. If not, see http://www.gnu.org/licenses/.
 \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.  
   
   
 \ WARNING: This file is processed by m4. Make sure your identifiers  \ WARNING: This file is processed by m4. Make sure your identifiers
Line 109 Line 108
 \E store-optimization on  \E store-optimization on
 \E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump  \E ' noop tail-nextp2 ! \ now INST_TAIL just stores, but does not jump
 \E  \E
 \E include-skipped-insts on \ static superinsts include cells for components  \E `include-skipped-insts' on \ static superinsts include cells for components
 \E                          \ useful for dynamic programming and  \E                            \ useful for dynamic programming and
 \E                          \ superinsts across entry points  \E                            \ superinsts across entry points
   
 \   \ 
 \   \ 
Line 203  INST_TAIL; Line 202  INST_TAIL;
 goto *next_code;  goto *next_code;
 #endif /* defined(NO_IP) */  #endif /* defined(NO_IP) */
   
   (dovalue) ( -- w )      gforth-internal paren_doval
   ""run-time routine for constants""
   w = *(Cell *)PFA(CFA);
   #ifdef NO_IP
   INST_TAIL;
   goto *next_code;
   #endif /* defined(NO_IP) */
   
 (dodoes) ( -- a_body R:a_retaddr )      gforth-internal paren_dodoes  (dodoes) ( -- a_body R:a_retaddr )      gforth-internal paren_dodoes
 ""run-time routine for @code{does>}-defined words""  ""run-time routine for @code{does>}-defined words""
 #ifdef NO_IP  #ifdef NO_IP
Line 222  fprintf(stderr, "dodoes to %x, push %x\n Line 229  fprintf(stderr, "dodoes to %x, push %x\n
 SET_IP(DOES_CODE1(CFA));  SET_IP(DOES_CODE1(CFA));
 #endif /* !defined(NO_IP) */  #endif /* !defined(NO_IP) */
   
 (does-handler) ( -- )   gforth-internal paren_does_handler  (doabicode) ( ... -- ...)       gforth-internal paren_doabicode
 ""just a slot to have an encoding for the DOESJUMP,   ""run-time routine for @code{ABI-code} definitions""
 which is no longer used anyway (!! eliminate this)""  abifunc *f = (abifunc *)PFA(CFA);
   Float *fp_mem = fp;
   sp = (*f)(sp, &fp_mem);
   fp = fp_mem;
   #ifdef NO_IP
   INST_TAIL;
   goto *next_code;
   #endif /* defined(NO_IP) */
   
   (do;abicode) ( ... -- ... ) gforth-internal paren_do_semicolon_abi_code
   ""run-time routine for @code{;abi-code}-defined words""
   Float *fp_mem = fp;
   Address body = (Address)PFA(CFA);
   semiabifunc *f = (semiabifunc *)DOES_CODE1(CFA);
   sp = (*f)(sp, &fp_mem, body);
   fp = fp_mem;
   #ifdef NO_IP
   INST_TAIL;
   goto *next_code;
   #endif /* defined(NO_IP) */
   
 \F [endif]  \F [endif]
   
Line 338  SET_IP((Xt *)a_target); Line 364  SET_IP((Xt *)a_target);
   
 \ condbranch(forthname,stackeffect,restline,code1,code2,forthcode)  \ condbranch(forthname,stackeffect,restline,code1,code2,forthcode)
 \ 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
 \ condbranch(forthname,stackeffect,restline,code1,code2,forthcode)  
 \ this is non-syntactical: code must open a brace that is closed by the macro  
 define(condbranch,  define(condbranch,
 $1 ( `#'a_target $2 ) $3  $1 ( `#'a_target $2 ) $3
 $4      #ifdef NO_IP  $4      #ifdef NO_IP
Line 349  $5 #ifdef NO_IP Line 373  $5 #ifdef NO_IP
 JUMP(a_target);  JUMP(a_target);
 #else  #else
 SET_IP((Xt *)a_target);  SET_IP((Xt *)a_target);
   ifelse(condbranch_opt,`1',`INST_TAIL; NEXT_P2;',`/* condbranch_opt=0 */')
 #endif  #endif
 }  }
   ifelse(condbranch_opt,`1',`SUPER_CONTINUE;',`/* condbranch_opt=0 */')
 $6  $6
   
 \+glocals  \+glocals
Line 364  $5 lp += nlocals; Line 390  $5 lp += nlocals;
 JUMP(a_target);  JUMP(a_target);
 #else  #else
 SET_IP((Xt *)a_target);  SET_IP((Xt *)a_target);
   ifelse(condbranch_opt,`1',`INST_TAIL; NEXT_P2;',`/* condbranch_opt=0 */')
 #endif  #endif
 }  }
   ifelse(condbranch_opt,`1',`SUPER_CONTINUE;',`/* condbranch_opt=0 */')
 \+  
 )  
   
 \ version that generates two jumps (not good for PR 15242 workaround)  
 define(condbranch_twojump,  
 $1 ( `#'a_target $2 ) $3  
 $4      #ifdef NO_IP  
 INST_TAIL;  
 #endif  
 $5      #ifdef NO_IP  
 JUMP(a_target);  
 #else  
 SET_IP((Xt *)a_target);  
 INST_TAIL; NEXT_P2;  
 #endif  
 }  
 SUPER_CONTINUE;  
 $6  
   
 \+glocals  
   
 $1-lp+!`#' ( `#'a_target `#'nlocals $2 ) $3_lp_plus_store_number  
 $4      #ifdef NO_IP  
 INST_TAIL;  
 #endif  
 $5      lp += nlocals;  
 #ifdef NO_IP  
 JUMP(a_target);  
 #else  
 SET_IP((Xt *)a_target);  
 INST_TAIL; NEXT_P2;  
 #endif  
 }  
 SUPER_CONTINUE;  
   
 \+  \+
 )  )
Line 619  SET_IP((Xt *)a_target); Line 612  SET_IP((Xt *)a_target);
      cell+       cell+
  THEN  >r ;   THEN  >r ;
   
   (try1)  ( ... a_oldhandler a_recovery -- R:a_recovery R:a_sp R:f_fp R:c_lp R:a_oldhandler a_newhandler ) gforth paren_try1
   a_sp = sp-1;
   f_fp = fp;
   c_lp = lp;
   a_newhandler = rp-5;
   
   (throw1) ( ... wball a_handler -- ... wball ) gforth paren_throw1
   rp = a_handler;
   lp = (Address)rp[1];
   fp = (Float *)rp[2];
   sp = (Cell *)rp[3];
   #ifndef NO_IP
   ip=IP;
   #endif
   SUPER_END;
   VM_JUMP(EXEC1(*(Xt *)rp[4]));
     
   
 \+  \+
   
 \ don't make any assumptions where the return stack is!!  \ don't make any assumptions where the return stack is!!
Line 635  i' ( R:w R:w2 -- R:w R:w2 w )  gforth  i Line 646  i' ( R:w R:w2 -- R:w R:w2 w )  gforth  i
   r> r> r> dup itmp ! >r >r >r itmp @ ;    r> r> r> dup itmp ! >r >r >r itmp @ ;
 variable itmp  variable itmp
   
 j       ( R:n R:d1 -- n R:n R:d1 )              core  j       ( R:w R:w1 R:w2 -- w R:w R:w1 R:w2 )    core
 :  :
 \ rp@ cell+ cell+ cell+ @ ;  \ rp@ cell+ cell+ cell+ @ ;
   r> r> r> r> dup itmp ! >r >r >r >r itmp @ ;    r> r> r> r> dup itmp ! >r >r >r >r itmp @ ;
 [IFUNDEF] itmp variable itmp [THEN]  [IFUNDEF] itmp variable itmp [THEN]
   
 k       ( R:n R:d1 R:d2 -- n R:n R:d1 R:d2 )            gforth  k       ( R:w R:w1 R:w2 R:w3 R:w4 -- w R:w R:w1 R:w2 R:w3 R:w4 )        gforth
 :  :
 \ rp@ [ 5 cells ] Literal + @ ;  \ rp@ [ 5 cells ] Literal + @ ;
   r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ;    r> r> r> r> r> r> dup itmp ! >r >r >r >r >r >r itmp @ ;
Line 728  c2 = toupper(c1); Line 739  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 - ;
   
 capscompare     ( c_addr1 u1 c_addr2 u2 -- n )  string  capscompare     ( c_addr1 u1 c_addr2 u2 -- n )  gforth
 ""Compare two strings lexicographically. If they are equal, @i{n} is 0; if  ""Compare two strings lexicographically. If they are equal, @i{n} is 0; if
 the first string is smaller, @i{n} is -1; if the first string is larger, @i{n}  the first string is smaller, @i{n} is -1; if the first string is larger, @i{n}
 is 1. Currently this is based on the machine's character  is 1. Currently this is based on the machine's character
Line 1092  lshift ( u1 n -- u2 )  core l_shift Line 1103  lshift ( u1 n -- u2 )  core l_shift
 :  :
     0 ?DO 2* LOOP ;      0 ?DO 2* LOOP ;
   
   umax    ( u1 u2 -- u )  core
   if (u1<u2)
     u = u2;
   else
     u = u1;
   :
    2dup u< IF swap THEN drop ;
   
   umin    ( u1 u2 -- u )  core
   if (u1<u2)
     u = u1;
   else
     u = u2;
   :
    2dup u> IF swap THEN drop ;
   
 \g compare  \g compare
   
 \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)  \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)
Line 1688  ucols=cols; Line 1715  ucols=cols;
   
 wcwidth ( u -- n )      gforth  wcwidth ( u -- n )      gforth
 ""The number of fixed-width characters per unicode character u""  ""The number of fixed-width characters per unicode character u""
   #ifdef HAVE_WCWIDTH
 n = wcwidth(u);  n = wcwidth(u);
   #else
   n = 1;
   #endif
   
 flush-icache    ( c_addr u -- ) gforth  flush_icache  flush-icache    ( c_addr u -- ) gforth  flush_icache
 ""Make sure that the instruction cache of the processor (if there is  ""Make sure that the instruction cache of the processor (if there is
Line 1700  supported on your machine (take a look a Line 1731  supported on your machine (take a look a
 your machine has a separate instruction cache. In such cases,  your machine has a separate instruction cache. In such cases,
 @code{flush-icache} does nothing instead of flushing the instruction  @code{flush-icache} does nothing instead of flushing the instruction
 cache.""  cache.""
 FLUSH_ICACHE(c_addr,u);  FLUSH_ICACHE((caddr_t)c_addr,u);
   
 (bye)   ( n -- )        gforth  paren_bye  (bye)   ( n -- )        gforth  paren_bye
 SUPER_END;  SUPER_END;
Line 1716  is the host operating system's expansion Line 1747  is the host operating system's expansion
 environment variable does not exist, @i{c-addr2 u2} specifies a string 0 characters  environment variable does not exist, @i{c-addr2 u2} specifies a string 0 characters
 in length.""  in length.""
 /* close ' to keep fontify happy */  /* close ' to keep fontify happy */
 c_addr2 = (Char *)getenv(cstr(c_addr1,u1,1));  char * string = cstr(c_addr1,u1);
   c_addr2 = (Char *)getenv(string);
 u2 = (c_addr2 == NULL ? 0 : strlen((char *)c_addr2));  u2 = (c_addr2 == NULL ? 0 : strlen((char *)c_addr2));
   free(string);
   
 open-pipe       ( c_addr u wfam -- wfileid wior )       gforth  open_pipe  open-pipe       ( c_addr u wfam -- wfileid wior )       gforth  open_pipe
 wfileid=(Cell)popen(cstr(c_addr,u,1),pfileattr[wfam]); /* ~ expansion of 1st arg? */  char * string = cstr(c_addr,u);
   fflush(stdout);
   wfileid=(Cell)popen(string,pfileattr[wfam]); /* ~ expansion of 1st arg? */
 wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */  wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */
   free(string);
   
 close-pipe      ( wfileid -- wretval wior )             gforth  close_pipe  close-pipe      ( wfileid -- wretval wior )             gforth  close_pipe
 wretval = pclose((FILE *)wfileid);  wretval = pclose((FILE *)wfileid);
Line 1788  if (a_addr1==NULL) Line 1824  if (a_addr1==NULL)
 else  else
   a_addr2 = (Cell *)realloc(a_addr1, u);    a_addr2 = (Cell *)realloc(a_addr1, u);
 wior = IOR(a_addr2==NULL);      /* !! Define a return code */  wior = IOR(a_addr2==NULL);      /* !! Define a return code */
   if (a_addr2==NULL)
     a_addr2 = a_addr1;
   
 strerror        ( n -- c_addr u )       gforth  strerror        ( n -- c_addr u )       gforth
 c_addr = (Char *)strerror(n);  c_addr = (Char *)strerror(n);
Line 1803  access the stack itself. The stack point Line 1841  access the stack itself. The stack point
 variables @code{gforth_SP} and @code{gforth_FP}.""  variables @code{gforth_SP} and @code{gforth_FP}.""
 /* This is a first attempt at support for calls to C. This may change in  /* This is a first attempt at support for calls to C. This may change in
    the future */     the future */
   IF_fpTOS(fp[0]=fpTOS);
 gforth_FP=fp;  gforth_FP=fp;
 gforth_SP=sp;  gforth_SP=sp;
   gforth_RP=rp;
   gforth_LP=lp;
   #ifdef HAS_LINKBACK
 ((void (*)())w)();  ((void (*)())w)();
   #else
   ((void (*)(void *))w)(&gforth_pointers);
   #endif
 sp=gforth_SP;  sp=gforth_SP;
 fp=gforth_FP;  fp=gforth_FP;
   rp=gforth_RP;
   lp=gforth_LP;
   IF_fpTOS(fpTOS=fp[0]);
   
 \+  \+
 \+file  \+file
Line 1816  close-file ( wfileid -- wior )  file clo Line 1864  close-file ( wfileid -- wior )  file clo
 wior = IOR(fclose((FILE *)wfileid)==EOF);  wior = IOR(fclose((FILE *)wfileid)==EOF);
   
 open-file       ( c_addr u wfam -- wfileid wior )       file    open_file  open-file       ( c_addr u wfam -- wfileid wior )       file    open_file
 wfileid = (Cell)fopen(tilde_cstr(c_addr, u, 1), fileattr[wfam]);  char * string = tilde_cstr(c_addr,u);
 wior =  IOR(wfileid == 0);  wfileid = opencreate_file(string, wfam, 0, &wior);
   free(string);
   
 create-file     ( c_addr u wfam -- wfileid wior )       file    create_file  create-file     ( c_addr u wfam -- wfileid wior )       file    create_file
 Cell    fd;  char * string = tilde_cstr(c_addr,u);
 fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[wfam], 0666);  wfileid = opencreate_file(string, wfam, O_CREAT|O_TRUNC, &wior);
 if (fd != -1) {  free(string);
   wfileid = (Cell)fdopen(fd, fileattr[wfam]);  
   wior = IOR(wfileid == 0);  
 } else {  
   wfileid = 0;  
   wior = IOR(1);  
 }  
   
 delete-file     ( c_addr u -- wior )            file    delete_file  delete-file     ( c_addr u -- wior )            file    delete_file
 wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1);  char * string = tilde_cstr(c_addr,u);
   wior = IOR(unlink(string)==-1);
   free(string);
   
 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 @i{c_addr1 u1} to new name @i{c_addr2 u2}""  ""Rename file @i{c_addr1 u1} to new name @i{c_addr2 u2}""
Line 1856  wior = IOR(ftruncate(fileno((FILE *)wfil Line 1901  wior = IOR(ftruncate(fileno((FILE *)wfil
 read-file       ( c_addr u1 wfileid -- u2 wior )        file    read_file  read-file       ( c_addr u1 wfileid -- u2 wior )        file    read_file
 /* !! fread does not guarantee enough */  /* !! fread does not guarantee enough */
 u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid);  u2 = fread(c_addr, sizeof(Char), u1, (FILE *)wfileid);
   if (u2>0)
      gf_regetc((FILE *)wfileid);
 wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));  wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
 /* !! is the value of ferror errno-compatible? */  /* !! is the value of ferror errno-compatible? */
 if (wior)  if (wior)
   clearerr((FILE *)wfileid);    clearerr((FILE *)wfileid);
   
 (read-line)     ( c_addr u1 wfileid -- u2 flag u3 wior ) file   paren_read_line  (read-line)     ( c_addr u1 wfileid -- u2 flag u3 wior ) file   paren_read_line
 struct Cellquad r = read_line(c_addr, u1, wfileid);  struct Cellquad r = read_line(c_addr, u1, (FILE *)wfileid);
 u2   = r.n1;  u2   = r.n1;
 flag = r.n2;  flag = r.n2;
 u3   = r.n3;  u3   = r.n3;
Line 1908  flag = FLAG(feof((FILE *) wfileid)); Line 1955  flag = FLAG(feof((FILE *) wfileid));
 open-dir        ( c_addr u -- wdirid wior )     gforth  open_dir  open-dir        ( c_addr u -- wdirid wior )     gforth  open_dir
 ""Open the directory specified by @i{c-addr, u}  ""Open the directory specified by @i{c-addr, u}
 and return @i{dir-id} for futher access to it.""  and return @i{dir-id} for futher access to it.""
 wdirid = (Cell)opendir(tilde_cstr(c_addr, u, 1));  char * string = tilde_cstr(c_addr,u);
   wdirid = (Cell)opendir(string);
 wior =  IOR(wdirid == 0);  wior =  IOR(wdirid == 0);
   free(string);
   
 read-dir        ( c_addr u1 wdirid -- u2 flag wior )    gforth  read_dir  read-dir        ( c_addr u1 wdirid -- u2 flag wior )    gforth  read_dir
 ""Attempt to read the next entry from the directory specified  ""Attempt to read the next entry from the directory specified
Line 1944  close-dir ( wdirid -- wior ) gforth clos Line 1993  close-dir ( wdirid -- wior ) gforth clos
 wior = IOR(closedir((DIR *)wdirid));  wior = IOR(closedir((DIR *)wdirid));
   
 filename-match  ( c_addr1 u1 c_addr2 u2 -- flag )       gforth  match_file  filename-match  ( c_addr1 u1 c_addr2 u2 -- flag )       gforth  match_file
 char * string = cstr(c_addr1, u1, 1);  char * string = cstr(c_addr1, u1);
 char * pattern = cstr(c_addr2, u2, 0);  char * pattern = cstr(c_addr2, u2);
 flag = FLAG(!fnmatch(pattern, string, 0));  flag = FLAG(!fnmatch(pattern, string, 0));
   free(string);
   free(pattern);
   
 set-dir ( c_addr u -- wior )    gforth set_dir  set-dir ( c_addr u -- wior )    gforth set_dir
 ""Change the current directory to @i{c-addr, u}.  ""Change the current directory to @i{c-addr, u}.
 Return an error if this is not possible""  Return an error if this is not possible""
 wior = IOR(chdir(tilde_cstr(c_addr, u, 1)));  char * string = tilde_cstr(c_addr, u);
   wior = IOR(chdir(string));
   free(string);
   
 get-dir ( c_addr1 u1 -- c_addr2 u2 )    gforth get_dir  get-dir ( c_addr1 u1 -- c_addr2 u2 )    gforth get_dir
 ""Store the current directory in the buffer specified by @{c-addr1, u1}.  ""Store the current directory in the buffer specified by @i{c-addr1, u1}.
 If the buffer size is not sufficient, return 0 0""  If the buffer size is not sufficient, return 0 0""
 c_addr2 = (Char *)getcwd((char *)c_addr1, u1);  c_addr2 = (Char *)getcwd((char *)c_addr1, u1);
 if(c_addr2 != NULL) {  if(c_addr2 != NULL) {
Line 1963  if(c_addr2 != NULL) { Line 2016  if(c_addr2 != NULL) {
   u2 = 0;    u2 = 0;
 }  }
   
   =mkdir ( c_addr u wmode -- wior )        gforth equals_mkdir
   ""Create directory @i{c-addr u} with mode @i{wmode}.""
   char * string = tilde_cstr(c_addr,u);
   wior = IOR(mkdir(string,wmode));
   free(string);
   
 \+  \+
   
 newline ( -- c_addr u ) gforth  newline ( -- c_addr u ) gforth
 ""String containing the newline sequence of the host OS""  ""String containing the newline sequence of the host OS""
 char newline[] = {  static const char newline[] = {
 #if DIRSEP=='/'  #if DIRSEP=='/'
 /* Unix */  /* Unix */
 '\n'  '\n'
Line 2008  duser = timeval2us(&time1); Line 2067  duser = timeval2us(&time1);
 dsystem = DZERO;  dsystem = DZERO;
 #endif  #endif
   
   ntime   ( -- dtime )    gforth
   ""Report the current time in nanoseconds since some epoch.""
   struct timespec time1;
   #ifdef HAVE_CLOCK_GETTIME
   clock_gettime(CLOCK_REALTIME,&time1);
   #else
   struct timeval time2;
   gettimeofday(&time2,NULL);
   time1.tv_sec = time2.tv_sec;1
   time1.tv_nsec = time2.tv_usec*1000;
   #endif
   dtime = timespec2ns(&time1);
   
 \+  \+
   
 \+floating  \+floating
Line 2099  r3 = r1/r2; Line 2171  r3 = r1/r2;
   
 f**     ( r1 r2 -- r3 ) float-ext       f_star_star  f**     ( r1 r2 -- r3 ) float-ext       f_star_star
 ""@i{r3} is @i{r1} raised to the @i{r2}th power.""  ""@i{r3} is @i{r1} raised to the @i{r2}th power.""
   CLOBBER_TOS_WORKAROUND_START;
 r3 = pow(r1,r2);  r3 = pow(r1,r2);
   CLOBBER_TOS_WORKAROUND_END;
   
 fm*     ( r1 n -- r2 )  gforth  fm_star  fm*     ( r1 n -- r2 )  gforth  fm_star
 r2 = r1*n;  r2 = r1*n;
Line 2141  n2 = n1*sizeof(Float); Line 2215  n2 = n1*sizeof(Float);
 floor   ( r1 -- r2 )    float  floor   ( r1 -- r2 )    float
 ""Round towards the next smaller integral value, i.e., round toward negative infinity.""  ""Round towards the next smaller integral value, i.e., round toward negative infinity.""
 /* !! unclear wording */  /* !! unclear wording */
   CLOBBER_TOS_WORKAROUND_START;
 r2 = floor(r1);  r2 = floor(r1);
   CLOBBER_TOS_WORKAROUND_END;
   
 fround  ( r1 -- r2 )    gforth  f_round  fround  ( r1 -- r2 )    float   f_round
 ""Round to the nearest integral value.""  ""Round to the nearest integral value.""
 r2 = rint(r1);  r2 = rint(r1);
   
Line 2166  int flag; Line 2242  int flag;
 int decpt;  int decpt;
 sig=ecvt(r, u, &decpt, &flag);  sig=ecvt(r, u, &decpt, &flag);
 n=(r==0. ? 1 : decpt);  n=(r==0. ? 1 : decpt);
   flag=signbit(r); /* not all ecvt()s do this as desired */
 f1=FLAG(flag!=0);  f1=FLAG(flag!=0);
 f2=FLAG(isdigit((unsigned)(sig[0]))!=0);  f2=FLAG(isdigit((unsigned)(sig[0]))!=0);
 siglen=strlen((char *)sig);  siglen=strlen((char *)sig);
Line 2185  representation. If the string represents Line 2262  representation. If the string represents
 true. Otherwise, @i{flag} is false. A string of blanks is a special  true. Otherwise, @i{flag} is false. A string of blanks is a special
 case and represents the floating-point number 0.""  case and represents the floating-point number 0.""
 Float r;  Float r;
 flag = to_float(c_addr, u, &r);  flag = to_float(c_addr, u, &r, '.');
 if (flag) {  if (flag) {
   fp--;    fp--;
   fp[0]=r;    fp[0]=r;
Line 2195  fabs ( r1 -- r2 ) float-ext f_abs Line 2272  fabs ( r1 -- r2 ) float-ext f_abs
 r2 = fabs(r1);  r2 = fabs(r1);
   
 facos   ( r1 -- r2 )    float-ext       f_a_cos  facos   ( r1 -- r2 )    float-ext       f_a_cos
   CLOBBER_TOS_WORKAROUND_START;
 r2 = acos(r1);  r2 = acos(r1);
   CLOBBER_TOS_WORKAROUND_END;
   
 fasin   ( r1 -- r2 )    float-ext       f_a_sine  fasin   ( r1 -- r2 )    float-ext       f_a_sine
   CLOBBER_TOS_WORKAROUND_START;
 r2 = asin(r1);  r2 = asin(r1);
   CLOBBER_TOS_WORKAROUND_END;
   
 fatan   ( r1 -- r2 )    float-ext       f_a_tan  fatan   ( r1 -- r2 )    float-ext       f_a_tan
 r2 = atan(r1);  r2 = atan(r1);
Line 2206  r2 = atan(r1); Line 2287  r2 = atan(r1);
 fatan2  ( r1 r2 -- r3 ) float-ext       f_a_tan_two  fatan2  ( r1 r2 -- r3 ) float-ext       f_a_tan_two
 ""@i{r1/r2}=tan(@i{r3}). ANS Forth does not require, but probably  ""@i{r1/r2}=tan(@i{r3}). ANS Forth does not require, but probably
 intends this to be the inverse of @code{fsincos}. In gforth it is.""  intends this to be the inverse of @code{fsincos}. In gforth it is.""
   CLOBBER_TOS_WORKAROUND_START;
 r3 = atan2(r1,r2);  r3 = atan2(r1,r2);
   CLOBBER_TOS_WORKAROUND_END;
   
 fcos    ( r1 -- r2 )    float-ext       f_cos  fcos    ( r1 -- r2 )    float-ext       f_cos
   CLOBBER_TOS_WORKAROUND_START;
 r2 = cos(r1);  r2 = cos(r1);
   CLOBBER_TOS_WORKAROUND_END;
   
 fexp    ( r1 -- r2 )    float-ext       f_e_x_p  fexp    ( r1 -- r2 )    float-ext       f_e_x_p
   CLOBBER_TOS_WORKAROUND_START;
 r2 = exp(r1);  r2 = exp(r1);
   CLOBBER_TOS_WORKAROUND_END;
   
 fexpm1  ( r1 -- r2 )    float-ext       f_e_x_p_m_one  fexpm1  ( r1 -- r2 )    float-ext       f_e_x_p_m_one
 ""@i{r2}=@i{e}**@i{r1}@minus{}1""  ""@i{r2}=@i{e}**@i{r1}@minus{}1""
Line 2222  extern double Line 2309  extern double
               const                const
 #endif  #endif
                     expm1(double);                      expm1(double);
   CLOBBER_TOS_WORKAROUND_START;
 r2 = expm1(r1);  r2 = expm1(r1);
   CLOBBER_TOS_WORKAROUND_END;
 #else  #else
   CLOBBER_TOS_WORKAROUND_START;
 r2 = exp(r1)-1.;  r2 = exp(r1)-1.;
   CLOBBER_TOS_WORKAROUND_END;
 #endif  #endif
   
 fln     ( r1 -- r2 )    float-ext       f_l_n  fln     ( r1 -- r2 )    float-ext       f_l_n
   CLOBBER_TOS_WORKAROUND_START;
 r2 = log(r1);  r2 = log(r1);
   CLOBBER_TOS_WORKAROUND_END;
   
 flnp1   ( r1 -- r2 )    float-ext       f_l_n_p_one  flnp1   ( r1 -- r2 )    float-ext       f_l_n_p_one
 ""@i{r2}=ln(@i{r1}+1)""  ""@i{r2}=ln(@i{r1}+1)""
   CLOBBER_TOS_WORKAROUND_START;
 #ifdef HAVE_LOG1P  #ifdef HAVE_LOG1P
 extern double  extern double
 #ifdef NeXT  #ifdef NeXT
Line 2242  r2 = log1p(r1); Line 2336  r2 = log1p(r1);
 #else  #else
 r2 = log(r1+1.);  r2 = log(r1+1.);
 #endif  #endif
   CLOBBER_TOS_WORKAROUND_END;
   
 flog    ( r1 -- r2 )    float-ext       f_log  flog    ( r1 -- r2 )    float-ext       f_log
 ""The decimal logarithm.""  ""The decimal logarithm.""
   CLOBBER_TOS_WORKAROUND_START;
 r2 = log10(r1);  r2 = log10(r1);
   CLOBBER_TOS_WORKAROUND_END;
   
 falog   ( r1 -- r2 )    float-ext       f_a_log  falog   ( r1 -- r2 )    float-ext       f_a_log
 ""@i{r2}=10**@i{r1}""  ""@i{r2}=10**@i{r1}""
 extern double pow10(double);  extern double pow10(double);
   CLOBBER_TOS_WORKAROUND_START;
 r2 = pow10(r1);  r2 = pow10(r1);
   CLOBBER_TOS_WORKAROUND_END;
   
 fsin    ( r1 -- r2 )    float-ext       f_sine  fsin    ( r1 -- r2 )    float-ext       f_sine
   CLOBBER_TOS_WORKAROUND_START;
 r2 = sin(r1);  r2 = sin(r1);
   CLOBBER_TOS_WORKAROUND_END;
   
 fsincos ( r1 -- r2 r3 ) float-ext       f_sine_cos  fsincos ( r1 -- r2 r3 ) float-ext       f_sine_cos
 ""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})""  ""@i{r2}=sin(@i{r1}), @i{r3}=cos(@i{r1})""
 r2 = sin(r1);  CLOBBER_TOS_WORKAROUND_START;
 r3 = cos(r1);  sincos(r1, &r2, &r3);
   CLOBBER_TOS_WORKAROUND_END;
   
 fsqrt   ( r1 -- r2 )    float-ext       f_square_root  fsqrt   ( r1 -- r2 )    float-ext       f_square_root
 r2 = sqrt(r1);  r2 = sqrt(r1);
   
 ftan    ( r1 -- r2 )    float-ext       f_tan  ftan    ( r1 -- r2 )    float-ext       f_tan
   CLOBBER_TOS_WORKAROUND_START;
 r2 = tan(r1);  r2 = tan(r1);
   CLOBBER_TOS_WORKAROUND_END;
 :  :
  fsincos f/ ;   fsincos f/ ;
   
 fsinh   ( r1 -- r2 )    float-ext       f_cinch  fsinh   ( r1 -- r2 )    float-ext       f_cinch
   CLOBBER_TOS_WORKAROUND_START;
 r2 = sinh(r1);  r2 = sinh(r1);
   CLOBBER_TOS_WORKAROUND_END;
 :  :
  fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ;   fexpm1 fdup fdup 1. d>f f+ f/ f+ f2/ ;
   
 fcosh   ( r1 -- r2 )    float-ext       f_cosh  fcosh   ( r1 -- r2 )    float-ext       f_cosh
   CLOBBER_TOS_WORKAROUND_START;
 r2 = cosh(r1);  r2 = cosh(r1);
   CLOBBER_TOS_WORKAROUND_END;
 :  :
  fexp fdup 1/f f+ f2/ ;   fexp fdup 1/f f+ f2/ ;
   
 ftanh   ( r1 -- r2 )    float-ext       f_tan_h  ftanh   ( r1 -- r2 )    float-ext       f_tan_h
   CLOBBER_TOS_WORKAROUND_START;
 r2 = tanh(r1);  r2 = tanh(r1);
   CLOBBER_TOS_WORKAROUND_END;
 :  :
  f2* fexpm1 fdup 2. d>f f+ f/ ;   f2* fexpm1 fdup 2. d>f f+ f/ ;
   
 fasinh  ( r1 -- r2 )    float-ext       f_a_cinch  fasinh  ( r1 -- r2 )    float-ext       f_a_cinch
   CLOBBER_TOS_WORKAROUND_START;
 r2 = asinh(r1);  r2 = asinh(r1);
   CLOBBER_TOS_WORKAROUND_END;
 :  :
  fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ;   fdup fdup f* 1. d>f f+ fsqrt f/ fatanh ;
   
 facosh  ( r1 -- r2 )    float-ext       f_a_cosh  facosh  ( r1 -- r2 )    float-ext       f_a_cosh
   CLOBBER_TOS_WORKAROUND_START;
 r2 = acosh(r1);  r2 = acosh(r1);
   CLOBBER_TOS_WORKAROUND_END;
 :  :
  fdup fdup f* 1. d>f f- fsqrt f+ fln ;   fdup fdup f* 1. d>f f- fsqrt f+ fln ;
   
 fatanh  ( r1 -- r2 )    float-ext       f_a_tan_h  fatanh  ( r1 -- r2 )    float-ext       f_a_tan_h
   CLOBBER_TOS_WORKAROUND_START;
 r2 = atanh(r1);  r2 = atanh(r1);
   CLOBBER_TOS_WORKAROUND_END;
 :  :
  fdup f0< >r fabs 1. d>f fover f- f/  f2* flnp1 f2/   fdup f0< >r fabs 1. d>f fover f- f/  f2* flnp1 f2/
  r> IF  fnegate  THEN ;   r> IF  fnegate  THEN ;
Line 2341  faxpy(ra, f_x, nstridex, f_y, nstridey, Line 2457  faxpy(ra, f_x, nstridex, f_y, nstridey,
      fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap       fdup dup f@ f* over + 2swap dup f@ f+ dup f! over + 2swap
  LOOP 2drop 2drop fdrop ;   LOOP 2drop 2drop fdrop ;
   
   >float1 ( c_addr u c -- f:... flag )    gforth  to_float1
   ""Actual stack effect: ( c_addr u c -- r t | f ).  Attempt to convert the
   character string @i{c-addr u} to internal floating-point
   representation. If the string represents a valid floating-point number
   @i{r} is placed on the floating-point stack and @i{flag} is
   true. Otherwise, @i{flag} is false. A string of blanks is a special
   case and represents the floating-point number 0.""
   Float r;
   flag = to_float(c_addr, u, &r, c);
   if (flag) {
     fp--;
     fp[0]=r;
   }
   
 \+  \+
   
 \ The following words access machine/OS/installation-dependent  \ The following words access machine/OS/installation-dependent
Line 2428  r = fp[u]; Line 2558  r = fp[u];
 \g syslib  \g syslib
   
 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)  u2 = gforth_dlopen(c_addr1, u1);
 #ifndef RTLD_GLOBAL  
 #define RTLD_GLOBAL 0  
 #endif  
 u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);  
 #else  
 #  ifdef _WIN32  
 u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));  
 #  else  
 #warning Define open-lib!  
 u2 = 0;  
 #  endif  
 #endif  
   
 lib-sym ( c_addr1 u1 u2 -- u3 ) gforth  lib_sym  lib-sym ( c_addr1 u1 u2 -- u3 ) gforth  lib_sym
 #if defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)  char * string = cstr(c_addr1, u1);
 u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1));  #ifdef HAVE_LIBLTDL
   u3 = (UCell) lt_dlsym((lt_dlhandle)u2, string);
   #elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
   u3 = (UCell) dlsym((void*)u2,string);
 #else  #else
 #  ifdef _WIN32  #  ifdef _WIN32
 u3 = (Cell) GetProcAddress((HMODULE)u2, cstr(c_addr1, u1, 1));  u3 = (Cell) GetProcAddress((HMODULE)u2, string);
 #  else  #  else
 #warning Define lib-sym!  #warning Define lib-sym!
 u3 = 0;  u3 = 0;
 #  endif  #  endif
 #endif  #endif
   free(string);
   
 wcall   ( ... u -- ... )        gforth  wcall   ( ... u -- ... )        gforth
 gforth_FP=fp;  gforth_FP=fp;
Line 2483  l! ( w c_addr -- ) gforth l_store Line 2605  l! ( w c_addr -- ) gforth l_store
 ""Store the bottom 32 bits of @i{w} at @i{c_addr}.""  ""Store the bottom 32 bits of @i{w} at @i{c_addr}.""
 *(Tetrabyte*)(c_addr) = w;  *(Tetrabyte*)(c_addr) = w;
   
 \+FFCALL  lib-error ( -- c_addr u )       gforth  lib_error
   ""Error message for last failed @code{open-lib} or @code{lib-sym}.""
 av-start-void   ( c_addr -- )   gforth  av_start_void  #ifdef HAVE_LIBLTDL
 av_start_void(alist, c_addr);  c_addr = (Char *)lt_dlerror();
   u = (c_addr == NULL) ? 0 : strlen((char *)c_addr);
 av-start-int    ( c_addr -- )   gforth  av_start_int  #elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
 av_start_int(alist, c_addr, &irv);  c_addr = dlerror();
   u = strlen(c_addr);
 av-start-float  ( c_addr -- )   gforth  av_start_float  #else
 av_start_float(alist, c_addr, &frv);  c_addr = "libltdl is not configured";
   u = strlen(c_addr);
 av-start-double ( c_addr -- )   gforth  av_start_double  #endif
 av_start_double(alist, c_addr, &drv);  
   be-w! ( w c_addr -- )   gforth w_store_be
 av-start-longlong       ( c_addr -- )   gforth  av_start_longlong  ""Store the bottom 16 bits of @i{w} at @i{c_addr} in big endian format.""
 av_start_longlong(alist, c_addr, &llrv);  c_addr[0] = w >> 8;
   c_addr[1] = w;
 av-start-ptr    ( c_addr -- )   gforth  av_start_ptr  
 av_start_ptr(alist, c_addr, void*, &prv);  be-l! ( w c_addr -- )   gforth l_store_be
   ""Store the bottom 32 bits of @i{w} at @i{c_addr} in big endian format.""
 av-int  ( w -- )  gforth  av_int  c_addr[0] = w >> 24;
 av_int(alist, w);  c_addr[1] = w >> 16;
   c_addr[2] = w >> 8;
 av-float        ( r -- )        gforth  av_float  c_addr[3] = w;
 av_float(alist, r);  
   le-w! ( w c_addr -- )   gforth w_store_le
 av-double       ( r -- )        gforth  av_double  ""Store the bottom 16 bits of @i{w} at @i{c_addr} in big endian format.""
 av_double(alist, r);  c_addr[1] = w >> 8;
   c_addr[0] = w;
 av-longlong     ( d -- )        gforth  av_longlong  
 #ifdef BUGGY_LL_SIZE  le-l! ( w c_addr -- )   gforth l_store_le
 av_longlong(alist, DLO(d));  ""Store the bottom 32 bits of @i{w} at @i{c_addr} in big endian format.""
 #else  c_addr[3] = w >> 24;
 av_longlong(alist, d);  c_addr[2] = w >> 16;
 #endif  c_addr[1] = w >> 8;
   c_addr[0] = w;
 av-ptr  ( c_addr -- )   gforth  av_ptr  
 av_ptr(alist, void*, c_addr);  be-uw@ ( c_addr -- u )  gforth w_fetch_be
   ""@i{u} is the zero-extended 16-bit big endian value stored at @i{c_addr}.""
 av-int-r  ( R:w -- )  gforth  av_int_r  u = (c_addr[0] << 8) | (c_addr[1]);
 av_int(alist, w);  
   be-ul@ ( c_addr -- u )  gforth l_fetch_be
 av-float-r      ( -- )  gforth  av_float_r  ""@i{u} is the zero-extended 32-bit big endian value stored at @i{c_addr}.""
 float r = *(Float*)lp;  u = ((Cell)c_addr[0] << 24) | (c_addr[1] << 16) | (c_addr[2] << 8) | (c_addr[3]);
 lp += sizeof(Float);  
 av_float(alist, r);  le-uw@ ( c_addr -- u )  gforth w_fetch_le
   ""@i{u} is the zero-extended 16-bit little endian value stored at @i{c_addr}.""
 av-double-r     ( -- )  gforth  av_double_r  u = (c_addr[1] << 8) | (c_addr[0]);
 double r = *(Float*)lp;  
 lp += sizeof(Float);  le-ul@ ( c_addr -- u )  gforth l_fetch_le
 av_double(alist, r);  ""@i{u} is the zero-extended 32-bit little endian value stored at @i{c_addr}.""
   u = ((Cell)c_addr[3] << 24) | (c_addr[2] << 16) | (c_addr[1] << 8) | (c_addr[0]);
 av-longlong-r   ( R:d -- )      gforth  av_longlong_r  
 #ifdef BUGGY_LL_SIZE  \+64bit
 av_longlong(alist, DLO(d));  
 #else  x! ( w c_addr -- )      gforth x_store
 av_longlong(alist, d);  ""Store the bottom 64 bits of @i{w} at 64-bit-aligned @i{c_addr}.""
 #endif  *(UOctabyte *)c_addr = w;
   
 av-ptr-r        ( R:c_addr -- ) gforth  av_ptr_r  ux@ ( c_addr -- u )     gforth u_x_fetch
 av_ptr(alist, void*, c_addr);  ""@i{u} is the zero-extended 64-bit value stored at 64-bit-aligned @i{c_addr}.""
   u = *(UOctabyte *)c_addr;
 av-call-void    ( ... -- ... )  gforth  av_call_void  
 SAVE_REGS  sx@ ( c_addr -- n )     gforth s_x_fetch
 av_call(alist);  ""@i{u} is the sign-extended 64-bit value stored at 64-bit-aligned @i{c_addr}.""
 REST_REGS  n = *(Octabyte *)c_addr;
   
 av-call-int     ( ... -- ... w )        gforth  av_call_int  be-x! ( w c_addr -- )   gforth b_e_x_store
 SAVE_REGS  ""Store the bottom 64 bits of @i{w} at @i{c_addr} in big endian format.""
 av_call(alist);  c_addr[0] = w >> 56;
 REST_REGS  c_addr[1] = w >> 48;
 w = irv;  c_addr[2] = w >> 40;
   c_addr[3] = w >> 32;
 av-call-float   ( ... -- ... r )        gforth  av_call_float  c_addr[4] = w >> 24;
 SAVE_REGS  c_addr[5] = w >> 16;
 av_call(alist);  c_addr[6] = w >> 8;
 REST_REGS  c_addr[7] = w;
 r = frv;  
   le-x! ( w c_addr -- )   gforth l_e_x_store
 av-call-double  ( ... -- ... r )        gforth  av_call_double  ""Store the bottom 64 bits of @i{w} at @i{c_addr} in big endian format.""
 SAVE_REGS  c_addr[7] = w >> 56;
 av_call(alist);  c_addr[6] = w >> 48;
 REST_REGS  c_addr[5] = w >> 40;
 r = drv;  c_addr[4] = w >> 32;
   c_addr[3] = w >> 24;
 av-call-longlong        ( ... -- ... d )        gforth  av_call_longlong  c_addr[2] = w >> 16;
 SAVE_REGS  c_addr[1] = w >> 8;
 av_call(alist);  c_addr[0] = w;
 REST_REGS  
 #ifdef BUGGY_LONG_LONG  be-ux@ ( c_addr -- u )  gforth b_e_u_x_fetch
 DLO_IS(d, llrv);  ""@i{u} is the zero-extended 64-bit big endian value stored at @i{c_addr}.""
 DHI_IS(d, 0);  u = (((Cell)(c_addr[0]) << 56) |
 #else       ((Cell)(c_addr[1]) << 48) |
 d = llrv;       ((Cell)(c_addr[2]) << 40) |
 #endif       ((Cell)(c_addr[3]) << 32) |
        ((Cell)(c_addr[4]) << 24) |
 av-call-ptr     ( ... -- ... c_addr )   gforth  av_call_ptr       ((Cell)(c_addr[5]) << 16) |
 SAVE_REGS       ((Cell)(c_addr[6]) << 8) |
 av_call(alist);       ((Cell)(c_addr[7])));
 REST_REGS  
 c_addr = prv;  le-ux@ ( c_addr -- u )  gforth l_e_u_x_fetch
   ""@i{u} is the zero-extended 64-bit little endian value stored at @i{c_addr}.""
 alloc-callback  ( a_ip -- c_addr )      gforth  alloc_callback  u = (((Cell)(c_addr[7]) << 56) |
 c_addr = (char *)alloc_callback(gforth_callback, (Xt *)a_ip);       ((Cell)(c_addr[6]) << 48) |
        ((Cell)(c_addr[5]) << 40) |
 va-start-void   ( -- )  gforth  va_start_void       ((Cell)(c_addr[4]) << 32) |
 va_start_void(gforth_clist);       ((Cell)(c_addr[3]) << 24) |
        ((Cell)(c_addr[2]) << 16) |
 va-start-int    ( -- )  gforth  va_start_int       ((Cell)(c_addr[1]) << 8) |
 va_start_int(gforth_clist);       ((Cell)(c_addr[0])));
   
 va-start-longlong       ( -- )  gforth  va_start_longlong  
 va_start_longlong(gforth_clist);  
   
 va-start-ptr    ( -- )  gforth  va_start_ptr  
 va_start_ptr(gforth_clist, (char *));  
   
 va-start-float  ( -- )  gforth  va_start_float  
 va_start_float(gforth_clist);  
   
 va-start-double ( -- )  gforth  va_start_double  
 va_start_double(gforth_clist);  
   
 va-arg-int      ( -- w )        gforth  va_arg_int  
 w = va_arg_int(gforth_clist);  
   
 va-arg-longlong ( -- d )        gforth  va_arg_longlong  
 #ifdef BUGGY_LONG_LONG  
 DLO_IS(d, va_arg_longlong(gforth_clist));  
 DHI_IS(d, 0);  
 #else  
 d = va_arg_longlong(gforth_clist);  
 #endif  
   
 va-arg-ptr      ( -- c_addr )   gforth  va_arg_ptr  
 c_addr = (char *)va_arg_ptr(gforth_clist,char*);  
   
 va-arg-float    ( -- r )        gforth  va_arg_float  
 r = va_arg_float(gforth_clist);  
   
 va-arg-double   ( -- r )        gforth  va_arg_double  
 r = va_arg_double(gforth_clist);  
   
 va-return-void ( -- )   gforth va_return_void  
 va_return_void(gforth_clist);  
 return 0;  
   
 va-return-int ( w -- )  gforth va_return_int  
 va_return_int(gforth_clist, w);  
 return 0;  
   
 va-return-ptr ( c_addr -- )     gforth va_return_ptr  
 va_return_ptr(gforth_clist, void *, c_addr);  
 return 0;  
   
 va-return-longlong ( d -- )     gforth va_return_longlong  
 #ifdef BUGGY_LONG_LONG  
 va_return_longlong(gforth_clist, d.lo);  
 #else  
 va_return_longlong(gforth_clist, d);  
 #endif  
 return 0;  
   
 va-return-float ( r -- )        gforth va_return_float  
 va_return_float(gforth_clist, r);  
 return 0;  
   
 va-return-double ( r -- )       gforth va_return_double  
 va_return_double(gforth_clist, r);  
 return 0;  
   
 \+  
   
 \+LIBFFI  
   
 ffi-type ( n -- a_type )        gforth ffi_type  
 static void* ffi_types[] =  
     { &ffi_type_void,  
       &ffi_type_uint8, &ffi_type_sint8,  
       &ffi_type_uint16, &ffi_type_sint16,  
       &ffi_type_uint32, &ffi_type_sint32,  
       &ffi_type_uint64, &ffi_type_sint64,  
       &ffi_type_float, &ffi_type_double, &ffi_type_longdouble,  
       &ffi_type_pointer };  
 a_type = ffi_types[n];  
   
 ffi-size ( n1 -- n2 )   gforth ffi_size  
 static int ffi_sizes[] =  
     { sizeof(ffi_cif), sizeof(ffi_closure) };  
 n2 = ffi_sizes[n1];  
   
 ffi-prep-cif ( a_atypes n a_rtype a_cif -- w )  gforth ffi_prep_cif  
 w = ffi_prep_cif((ffi_cif *)a_cif, FFI_DEFAULT_ABI, n,  
          (ffi_type *)a_rtype, (ffi_type **)a_atypes);  
   
 ffi-call ( a_avalues a_rvalue a_ip a_cif -- )   gforth ffi_call  
 SAVE_REGS  
 ffi_call((ffi_cif *)a_cif, (void(*)())a_ip, (void *)a_rvalue, (void **)a_avalues);  
 REST_REGS  
   
 ffi-prep-closure ( a_ip a_cif a_closure -- w )  gforth ffi_prep_closure  
 w = ffi_prep_closure((ffi_closure *)a_closure, (ffi_cif *)a_cif, gforth_callback, (void *)a_ip);  
   
 ffi-2@ ( a_addr -- d )  gforth ffi_2fetch  
 #ifdef BUGGY_LONG_LONG  
 DLO_IS(d, *(Cell*)(*a_addr));  
 DHI_IS(d, 0);  
 #else  
 d = *(DCell*)(a_addr);  
 #endif  
   
 ffi-2! ( d a_addr -- )  gforth ffi_2store  
 #ifdef BUGGY_LONG_LONG  
 *(Cell*)(a_addr) = DLO(d);  
 #else  
 *(DCell*)(a_addr) = d;  
 #endif  
   
 ffi-arg-int ( -- w )    gforth ffi_arg_int  
 w = *(int *)(*gforth_clist++);  
   
 ffi-arg-long ( -- w )   gforth ffi_arg_long  
 w = *(long *)(*gforth_clist++);  
   
 ffi-arg-longlong ( -- d )       gforth ffi_arg_longlong  
 #ifdef BUGGY_LONG_LONG  
 DLO_IS(d, *(Cell*)(*gforth_clist++));  
 DHI_IS(d, -(*(Cell*)(*gforth_clist++)<0));  
 #else  
 d = *(DCell*)(*gforth_clist++);  
 #endif  
   
 ffi-arg-dlong ( -- d )  gforth ffi_arg_dlong  
 #ifdef BUGGY_LONG_LONG  
 DLO_IS(d, *(Cell*)(*gforth_clist++));  
 DHI_IS(d, -(*(Cell*)(*gforth_clist++)<0));  
 #else  
 d = *(Cell*)(*gforth_clist++);  
 #endif  
   
 ffi-arg-ptr ( -- c_addr )       gforth ffi_arg_ptr  
 c_addr = *(Char **)(*gforth_clist++);  
   
 ffi-arg-float ( -- r )  gforth ffi_arg_float  
 r = *(float*)(*gforth_clist++);  
   
 ffi-arg-double ( -- r ) gforth ffi_arg_double  
 r = *(double*)(*gforth_clist++);  
   
 ffi-ret-void ( -- )     gforth ffi_ret_void  
 return 0;  
   
 ffi-ret-int ( w -- )    gforth ffi_ret_int  
 *(int*)(gforth_ritem) = w;  
 return 0;  
   
 ffi-ret-longlong ( d -- )       gforth ffi_ret_longlong  
 #ifdef BUGGY_LONG_LONG  
 *(Cell*)(gforth_ritem) = DLO(d);  
 #else  
 *(DCell*)(gforth_ritem) = d;  
 #endif  
 return 0;  
   
 ffi-ret-dlong ( d -- )  gforth ffi_ret_dlong  
 #ifdef BUGGY_LONG_LONG  
 *(Cell*)(gforth_ritem) = DLO(d);  
 #else  
 *(Cell*)(gforth_ritem) = d;  
 #endif  
 return 0;  
   
 ffi-ret-long ( n -- )   gforth ffi_ret_long  
 *(Cell*)(gforth_ritem) = n;  
 return 0;  
   
 ffi-ret-ptr ( c_addr -- )       gforth ffi_ret_ptr  
 *(Char **)(gforth_ritem) = c_addr;  
 return 0;  
   
 ffi-ret-float ( r -- )  gforth ffi_ret_float  
 *(float*)(gforth_ritem) = r;  
 return 0;  
   
 ffi-ret-double ( r -- ) gforth ffi_ret_double  
 *(double*)(gforth_ritem) = r;  
 return 0;  
   
 \+  
   
 \+OLDCALL  
   
 define(`uploop',  
        `pushdef(`$1', `$2')_uploop(`$1', `$2', `$3', `$4', `$5')`'popdef(`$1')')  
 define(`_uploop',  
        `ifelse($1, `$3', `$5',  
                `$4`'define(`$1', incr($1))_uploop(`$1', `$2', `$3', `$4', `$5')')')  
   
 \ argflist(argnum): Forth argument list  
 define(argflist,  
        `ifelse($1, 0, `',  
                `uploop(`_i', 1, $1, ``u''`_i ', ``u''`_i')')')  
 \ argdlist(argnum): declare C's arguments  
 define(argdlist,  
        `ifelse($1, 0, `',  
                `uploop(`_i', 1, $1, `Cell, ', `Cell')')')  
 \ argclist(argnum): pass C's arguments  
 define(argclist,  
        `ifelse($1, 0, `',  
                `uploop(`_i', 1, $1, ``u''`_i, ', ``u''`_i')')')  
 \ icall(argnum)  
 define(icall,  
 `icall$1        ( argflist($1) u -- uret )      gforth  
 uret = (SYSCALL(Cell(*)(argdlist($1)))u)(argclist($1));  
   
 ')  
 define(fcall,  
 `fcall$1        ( argflist($1) u -- rret )      gforth  
 rret = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1));  
   
 ')  
   
 \ close ' to keep fontify happy  
   
 uploop(i, 0, 7, `icall(i)')  
 icall(20)  
 uploop(i, 0, 7, `fcall(i)')  
 fcall(20)  
   
 \+  \+
 \+  \+
   
 \g peephole  \g peephole
   
 \+peephole  \+peephole
Line 2861  a_addr = groups; Line 2764  a_addr = groups;
   
 \+  \+
   
   \g primitive_centric
   
   \ primitives for primitive-centric code
   \ another one is does-exec
   
   abi-call        ( #a_callee ... -- ... ) gforth-internal abi_call
   /* primitive for compiled ABI-CODE words */
   abifunc *f = (abifunc *)a_callee;
   Float *fp_mem = fp;
   sp = (*f)(sp, &fp_mem);
   fp = fp_mem;
   
   ;abi-code-exec ( #a_cfa ... -- ... ) gforth-internal semi_abi_code_exec
   /* primitive for performing ;ABI-CODE words */
   Float *fp_mem = fp;
   semiabifunc *f = (semiabifunc *)DOES_CODE1(a_cfa);
   Address body = (Address)PFA(a_cfa);
   sp = (*f)(sp, &fp_mem, body);
   fp = fp_mem;
   
   lit-execute     ( #a_addr -- )  new     lit_execute
   /* for ;code and code words; a static superinstruction would be more general, 
      but VM_JUMP is currently not supported there */
   #ifndef NO_IP
   ip=IP;
   #endif
   SUPER_END;
   VM_JUMP(EXEC1((Xt)a_addr));
   
   \+objects
   \g object_pointer
   
   >o ( c_addr -- r:c_old )        new     to_o
   c_old = op;
   op = c_addr;
   
   o> ( r:c_addr -- )              new     o_restore
   op = c_addr;
   
   o#+ ( #w -- c_addr )            new     o_lit_plus
   c_addr = op + w;
   
   \+
 \g static_super  \g static_super
   
 ifdef(`STACK_CACHE_FILE',  ifdef(`STACK_CACHE_FILE',

Removed from v.1.213  
changed lines
  Added in v.1.273


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