Diff for /gforth/prim between versions 1.238 and 1.272

version 1.238, 2008/10/15 15:27:33 version 1.272, 2012/05/26 10:20:01
Line 1 Line 1
 \ Gforth primitives  \ Gforth primitives
   
 \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005,2006,2007,2008 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.
   
Line 229  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 593  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 1066  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 1694  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 1766  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 1789  gforth_LP=lp; Line 1849  gforth_LP=lp;
 #ifdef HAS_LINKBACK  #ifdef HAS_LINKBACK
 ((void (*)())w)();  ((void (*)())w)();
 #else  #else
 ((void (*)(void *))w)(gforth_pointers);  ((void (*)(void *))w)(&gforth_pointers);
 #endif  #endif
 sp=gforth_SP;  sp=gforth_SP;
 fp=gforth_FP;  fp=gforth_FP;
Line 1804  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 = opencreate_file(tilde_cstr(c_addr,u,1), wfam, 0, &wior);  char * string = tilde_cstr(c_addr,u);
   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
 wfileid = opencreate_file(tilde_cstr(c_addr,u,1), wfam, O_CREAT|O_TRUNC, &wior);  char * string = tilde_cstr(c_addr,u);
   wfileid = opencreate_file(string, wfam, O_CREAT|O_TRUNC, &wior);
   free(string);
   
 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 1835  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 1887  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 1923  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 @i{c-addr1, u1}.  ""Store the current directory in the buffer specified by @i{c-addr1, u1}.
Line 1944  if(c_addr2 != NULL) { Line 2018  if(c_addr2 != NULL) {
   
 =mkdir ( c_addr u wmode -- wior )        gforth equals_mkdir  =mkdir ( c_addr u wmode -- wior )        gforth equals_mkdir
 ""Create directory @i{c-addr u} with mode @i{wmode}.""  ""Create directory @i{c-addr u} with mode @i{wmode}.""
 wior = IOR(mkdir(tilde_cstr(c_addr,u,1),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 1991  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 2082  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 2124  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 )    float   f_round  fround  ( r1 -- r2 )    float   f_round
 ""Round to the nearest integral value.""  ""Round to the nearest integral value.""
Line 2149  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 2168  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 2178  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 2189  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 2205  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 2225  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 2324  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 2414  open-lib ( c_addr1 u1 -- u2 ) gforth ope Line 2561  open-lib ( c_addr1 u1 -- u2 ) gforth ope
 u2 = gforth_dlopen(c_addr1, u1);  u2 = gforth_dlopen(c_addr1, u1);
   
 lib-sym ( c_addr1 u1 u2 -- u3 ) gforth  lib_sym  lib-sym ( c_addr1 u1 u2 -- u3 ) gforth  lib_sym
   char * string = cstr(c_addr1, u1);
 #ifdef HAVE_LIBLTDL  #ifdef HAVE_LIBLTDL
 u3 = (UCell) lt_dlsym((lt_dlhandle)u2, cstr(c_addr1, u1, 1));  u3 = (UCell) lt_dlsym((lt_dlhandle)u2, string);
 #elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)  #elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
 u3 = (UCell) dlsym((void*)u2,cstr(c_addr1, u1, 1));  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 2461  lib-error ( -- c_addr u )       gforth Line 2610  lib-error ( -- c_addr u )       gforth
 #ifdef HAVE_LIBLTDL  #ifdef HAVE_LIBLTDL
 c_addr = (Char *)lt_dlerror();  c_addr = (Char *)lt_dlerror();
 u = (c_addr == NULL) ? 0 : strlen((char *)c_addr);  u = (c_addr == NULL) ? 0 : strlen((char *)c_addr);
   #elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
   c_addr = dlerror();
   u = strlen(c_addr);
 #else  #else
 c_addr = "libltdl is not configured";  c_addr = "libltdl is not configured";
 u = strlen(c_addr);  u = strlen(c_addr);
 #endif  #endif
   
   be-w! ( w c_addr -- )   gforth w_store_be
   ""Store the bottom 16 bits of @i{w} at @i{c_addr} in big endian format.""
   c_addr[0] = w >> 8;
   c_addr[1] = w;
   
   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.""
   c_addr[0] = w >> 24;
   c_addr[1] = w >> 16;
   c_addr[2] = w >> 8;
   c_addr[3] = w;
   
   le-w! ( w c_addr -- )   gforth w_store_le
   ""Store the bottom 16 bits of @i{w} at @i{c_addr} in big endian format.""
   c_addr[1] = w >> 8;
   c_addr[0] = w;
   
   le-l! ( w c_addr -- )   gforth l_store_le
   ""Store the bottom 32 bits of @i{w} at @i{c_addr} in big endian format.""
   c_addr[3] = w >> 24;
   c_addr[2] = w >> 16;
   c_addr[1] = w >> 8;
   c_addr[0] = w;
   
   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}.""
   u = (c_addr[0] << 8) | (c_addr[1]);
   
   be-ul@ ( c_addr -- u )  gforth l_fetch_be
   ""@i{u} is the zero-extended 32-bit big endian value stored at @i{c_addr}.""
   u = ((Cell)c_addr[0] << 24) | (c_addr[1] << 16) | (c_addr[2] << 8) | (c_addr[3]);
   
   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}.""
   u = (c_addr[1] << 8) | (c_addr[0]);
   
   le-ul@ ( c_addr -- u )  gforth l_fetch_le
   ""@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]);
   
   \+64bit
   
   x! ( w c_addr -- )      gforth x_store
   ""Store the bottom 64 bits of @i{w} at 64-bit-aligned @i{c_addr}.""
   *(UOctabyte *)c_addr = w;
   
   ux@ ( c_addr -- u )     gforth u_x_fetch
   ""@i{u} is the zero-extended 64-bit value stored at 64-bit-aligned @i{c_addr}.""
   u = *(UOctabyte *)c_addr;
   
   sx@ ( c_addr -- n )     gforth s_x_fetch
   ""@i{u} is the sign-extended 64-bit value stored at 64-bit-aligned @i{c_addr}.""
   n = *(Octabyte *)c_addr;
   
   be-x! ( w c_addr -- )   gforth b_e_x_store
   ""Store the bottom 64 bits of @i{w} at @i{c_addr} in big endian format.""
   c_addr[0] = w >> 56;
   c_addr[1] = w >> 48;
   c_addr[2] = w >> 40;
   c_addr[3] = w >> 32;
   c_addr[4] = w >> 24;
   c_addr[5] = w >> 16;
   c_addr[6] = w >> 8;
   c_addr[7] = w;
   
   le-x! ( w c_addr -- )   gforth l_e_x_store
   ""Store the bottom 64 bits of @i{w} at @i{c_addr} in big endian format.""
   c_addr[7] = w >> 56;
   c_addr[6] = w >> 48;
   c_addr[5] = w >> 40;
   c_addr[4] = w >> 32;
   c_addr[3] = w >> 24;
   c_addr[2] = w >> 16;
   c_addr[1] = w >> 8;
   c_addr[0] = w;
   
   be-ux@ ( c_addr -- u )  gforth b_e_u_x_fetch
   ""@i{u} is the zero-extended 64-bit big endian value stored at @i{c_addr}.""
   u = (((Cell)(c_addr[0]) << 56) |
        ((Cell)(c_addr[1]) << 48) |
        ((Cell)(c_addr[2]) << 40) |
        ((Cell)(c_addr[3]) << 32) |
        ((Cell)(c_addr[4]) << 24) |
        ((Cell)(c_addr[5]) << 16) |
        ((Cell)(c_addr[6]) << 8) |
        ((Cell)(c_addr[7])));
   
   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}.""
   u = (((Cell)(c_addr[7]) << 56) |
        ((Cell)(c_addr[6]) << 48) |
        ((Cell)(c_addr[5]) << 40) |
        ((Cell)(c_addr[4]) << 32) |
        ((Cell)(c_addr[3]) << 24) |
        ((Cell)(c_addr[2]) << 16) |
        ((Cell)(c_addr[1]) << 8) |
        ((Cell)(c_addr[0])));
   
   \+
 \+  \+
 \g peephole  \g peephole
   
Line 2513  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));
   
   
 \g static_super  \g static_super
   
 ifdef(`STACK_CACHE_FILE',  ifdef(`STACK_CACHE_FILE',

Removed from v.1.238  
changed lines
  Added in v.1.272


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