Diff for /gforth/prim between versions 1.174 and 1.195

version 1.174, 2005/08/02 12:00:51 version 1.195, 2006/06/09 15:51:24
Line 1 Line 1
 \ Gforth primitives  \ Gforth primitives
   
 \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004 Free Software Foundation, Inc.  \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005 Free Software Foundation, Inc.
   
 \ This file is part of Gforth.  \ This file is part of Gforth.
   
Line 719  c2 = toupper(c1); Line 719  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
   ""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}
   is 1. Currently this is based on the machine's character
   comparison. In the future, this may change to consider the current
   locale and its collation order.""
   /* close ' to keep fontify happy */ 
   n = capscompare(c_addr1, u1, c_addr2, u2);
   
 /string ( c_addr1 u1 n -- c_addr2 u2 )  string  slash_string  /string ( c_addr1 u1 n -- c_addr2 u2 )  string  slash_string
 ""Adjust the string specified by @i{c-addr1, u1} to remove @i{n}  ""Adjust the string specified by @i{c-addr1, u1} to remove @i{n}
 characters from the start of the string.""  characters from the start of the string.""
Line 873  division by 2 (note that @code{/} not ne Line 882  division by 2 (note that @code{/} not ne
 n2 = n1>>1;  n2 = n1>>1;
 :  :
  dup MINI and IF 1 ELSE 0 THEN   dup MINI and IF 1 ELSE 0 THEN
  [ bits/byte cell * 1- ] literal    [ bits/char cell * 1- ] literal 
  0 DO 2* swap dup 2* >r MINI and    0 DO 2* swap dup 2* >r MINI and 
      IF 1 ELSE 0 THEN or r> swap       IF 1 ELSE 0 THEN or r> swap
  LOOP nip ;   LOOP nip ;
Line 1229  useraddr ( #u -- a_addr ) new Line 1238  useraddr ( #u -- a_addr ) new
 a_addr = (Cell *)(up+u);  a_addr = (Cell *)(up+u);
   
 up!     ( a_addr -- )   gforth  up_store  up!     ( a_addr -- )   gforth  up_store
 UP=up=(char *)a_addr;  gforth_UP=up=(Address)a_addr;
 :  :
  up ! ;   up ! ;
 Variable UP  Variable UP
Line 1637  n=1; Line 1646  n=1;
   
 \g hostos  \g hostos
   
 key-file        ( wfileid -- n )                gforth  paren_key_file  key-file        ( wfileid -- c )                gforth  paren_key_file
   ""Read one character @i{c} from @i{wfileid}.  This word disables
   buffering for @i{wfileid}.  If you want to read characters from a
   terminal in non-canonical (raw) mode, you have to put the terminal in
   non-canonical mode yourself (using the C interface); the exception is
   @code{stdin}: Gforth automatically puts it into non-canonical mode.""
 #ifdef HAS_FILE  #ifdef HAS_FILE
 fflush(stdout);  fflush(stdout);
 n = key((FILE*)wfileid);  c = key((FILE*)wfileid);
 #else  #else
 n = key(stdin);  c = key(stdin);
 #endif  #endif
   
 key?-file       ( wfileid -- n )                facility        key_q_file  key?-file       ( wfileid -- f )                gforth  key_q_file
   ""@i{f} is true if at least one character can be read from @i{wfileid}
   without blocking.  If you also want to use @code{read-file} or
   @code{read-line} on the file, you have to call @code{key?-file} or
   @code{key-file} first (these two words disable buffering).""
 #ifdef HAS_FILE  #ifdef HAS_FILE
 fflush(stdout);  fflush(stdout);
 n = key_query((FILE*)wfileid);  f = key_query((FILE*)wfileid);
 #else  #else
 n = key_query(stdin);  f = key_query(stdin);
 #endif  #endif
   
 \+os  \+os
   
 stdin   ( -- wfileid )  gforth  stdin   ( -- wfileid )  gforth
   ""The standard input file of the Gforth process.""
 wfileid = (Cell)stdin;  wfileid = (Cell)stdin;
   
 stdout  ( -- wfileid )  gforth  stdout  ( -- wfileid )  gforth
   ""The standard output file of the Gforth process.""
 wfileid = (Cell)stdout;  wfileid = (Cell)stdout;
   
 stderr  ( -- wfileid )  gforth  stderr  ( -- wfileid )  gforth
   ""The standard error output file of the Gforth process.""
 wfileid = (Cell)stderr;  wfileid = (Cell)stderr;
   
 form    ( -- urows ucols )      gforth  form    ( -- urows ucols )      gforth
Line 1672  with the window size."" Line 1693  with the window size.""
 urows=rows;  urows=rows;
 ucols=cols;  ucols=cols;
   
   wcwidth ( u -- n )      gforth
   ""The number of fixed-width characters per unicode character u""
   n = wcwidth(u);
   
 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
 one) does not contain stale data at @i{c-addr} and @i{u} bytes  one) does not contain stale data at @i{c-addr} and @i{u} bytes
Line 1698  is the host operating system's expansion Line 1723  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 = getenv(cstr(c_addr1,u1,1));  c_addr2 = (Char *)getenv(cstr(c_addr1,u1,1));
 u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));  u2 = (c_addr2 == NULL ? 0 : strlen((char *)c_addr2));
   
 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? */  wfileid=(Cell)popen(cstr(c_addr,u,1),pfileattr[wfam]); /* ~ expansion of 1st arg? */
Line 1775  else Line 1800  else
 wior = IOR(a_addr2==NULL);      /* !! Define a return code */  wior = IOR(a_addr2==NULL);      /* !! Define a return code */
   
 strerror        ( n -- c_addr u )       gforth  strerror        ( n -- c_addr u )       gforth
 c_addr = strerror(n);  c_addr = (Char *)strerror(n);
 u = strlen(c_addr);  u = strlen((char *)c_addr);
   
 strsignal       ( n -- c_addr u )       gforth  strsignal       ( n -- c_addr u )       gforth
 c_addr = (Address)strsignal(n);  c_addr = (Char *)strsignal(n);
 u = strlen(c_addr);  u = strlen((char *)c_addr);
   
 call-c  ( ... w -- ... )        gforth  call_c  call-c  ( ... w -- ... )        gforth  call_c
 ""Call the C function pointed to by @i{w}. The C function has to  ""Call the C function pointed to by @i{w}. The C function has to
Line 1788  access the stack itself. The stack point Line 1813  access the stack itself. The stack point
 variables @code{SP} and @code{FP}.""  variables @code{SP} and @code{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 */
 FP=fp;  gforth_FP=fp;
 SP=sp;  gforth_SP=sp;
 ((void (*)())w)();  ((void (*)())w)();
 sp=SP;  sp=gforth_SP;
 fp=FP;  fp=gforth_FP;
   
 \+  \+
 \+file  \+file
Line 1916  if(dent == NULL) { Line 1941  if(dent == NULL) {
   u2 = 0;    u2 = 0;
   flag = 0;    flag = 0;
 } else {  } else {
   u2 = strlen(dent->d_name);    u2 = strlen((char *)dent->d_name);
   if(u2 > u1) {    if(u2 > u1) {
     u2 = u1;      u2 = u1;
     wior = -512-ENAMETOOLONG;      wior = -512-ENAMETOOLONG;
Line 1941  wior = IOR(chdir(tilde_cstr(c_addr, u, 1 Line 1966  wior = IOR(chdir(tilde_cstr(c_addr, u, 1
 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 @{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 = getcwd(c_addr1, u1);  c_addr2 = (Char *)getcwd((char *)c_addr1, u1);
 if(c_addr2 != NULL) {  if(c_addr2 != NULL) {
   u2 = strlen(c_addr2);    u2 = strlen((char *)c_addr2);
 } else {  } else {
   u2 = 0;    u2 = 0;
 }  }
Line 1961  char newline[] = { Line 1986  char newline[] = {
 '\r','\n'  '\r','\n'
 #endif  #endif
 };  };
 c_addr=newline;  c_addr=(Char *)newline;
 u=sizeof(newline);  u=sizeof(newline);
 :  :
  "newline count ;   "newline count ;
Line 2002  dsystem = DZERO; Line 2027  dsystem = DZERO;
 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)
   
   s>f     ( n -- r )              float   s_to_f
   r = n;
   
 d>f     ( d -- r )              float   d_to_f  d>f     ( d -- r )              float   d_to_f
 #ifdef BUGGY_LL_D2F  #ifdef BUGGY_LL_D2F
 extern double ldexp(double x, int exp);  extern double ldexp(double x, int exp);
Line 2022  f>d ( r -- d )  float f_to_d Line 2050  f>d ( r -- d )  float f_to_d
 extern DCell double2ll(Float r);  extern DCell double2ll(Float r);
 d = double2ll(r);  d = double2ll(r);
   
   f>s     ( r -- n )              float   f_to_s
   n = (Cell)r;
   
 f!      ( r f_addr -- ) float   f_store  f!      ( r f_addr -- ) float   f_store
 ""Store @i{r} into the float at address @i{f-addr}.""  ""Store @i{r} into the float at address @i{f-addr}.""
 *f_addr = r;  *f_addr = r;
Line 2080  f** ( r1 r2 -- r3 ) float-ext f_star_sta Line 2111  f** ( r1 r2 -- r3 ) float-ext f_star_sta
 ""@i{r3} is @i{r1} raised to the @i{r2}th power.""  ""@i{r3} is @i{r1} raised to the @i{r2}th power.""
 r3 = pow(r1,r2);  r3 = pow(r1,r2);
   
   fm*     ( r1 n -- r2 )  gforth  fm_star
   r2 = r1*n;
   
   fm/     ( r1 n -- r2 )  gforth  fm_slash
   r2 = r1/n;
   
   fm*/    ( r1 n1 n2 -- r2 )      gforth  fm_star_slash
   r2 = (r1*n1)/n2;
   
   f**2    ( r1 -- r2 )    gforth  fm_square
   r2 = r1*r1;
   
 fnegate ( r1 -- r2 )    float   f_negate  fnegate ( r1 -- r2 )    float   f_negate
 r2 = - r1;  r2 = - r1;
   
Line 2135  sig=ecvt(r, u, &decpt, &flag); Line 2178  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((unsigned)(sig[0]))!=0);  f2=FLAG(isdigit((unsigned)(sig[0]))!=0);
 siglen=strlen(sig);  siglen=strlen((char *)sig);
 if (siglen>u) /* happens in glibc-2.1.3 if 999.. is rounded up */  if (siglen>u) /* happens in glibc-2.1.3 if 999.. is rounded up */
   siglen=u;    siglen=u;
 if (!f2) /* workaround Cygwin trailing 0s for Inf and Nan */  if (!f2) /* workaround Cygwin trailing 0s for Inf and Nan */
Line 2422  u3 = 0; Line 2465  u3 = 0;
 #endif  #endif
   
 wcall   ( ... u -- ... )        gforth  wcall   ( ... u -- ... )        gforth
 FP=fp;  gforth_FP=fp;
 sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &FP);  sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &gforth_FP);
 fp=FP;  fp=gforth_FP;
   
   uw@ ( c_addr -- u )     gforth u_w_fetch
   ""@i{u} is the zero-extended 16-bit value stored at @i{c_addr}.""
   u = *(UWyde*)(c_addr);
   
   sw@ ( c_addr -- n )     gforth s_w_fetch
   ""@i{n} is the sign-extended 16-bit value stored at @i{c_addr}.""
   n = *(Wyde*)(c_addr);
   
   w! ( w c_addr -- )      gforth w_store
   ""Store the bottom 16 bits of @i{w} at @i{c_addr}.""
   *(Wyde*)(c_addr) = w;
   
   ul@ ( c_addr -- u )     gforth u_l_fetch
   ""@i{u} is the zero-extended 32-bit value stored at @i{c_addr}.""
   u = *(UTetrabyte*)(c_addr);
   
   sl@ ( c_addr -- n )     gforth s_l_fetch
   ""@i{n} is the sign-extended 32-bit value stored at @i{c_addr}.""
   n = *(Tetrabyte*)(c_addr);
   
   l! ( w c_addr -- )      gforth l_store
   ""Store the bottom 32 bits of @i{w} at @i{c_addr}.""
   *(Tetrabyte*)(c_addr) = w;
   
 \+FFCALL  \+FFCALL
   
Line 2529  REST_REGS Line 2596  REST_REGS
 c_addr = prv;  c_addr = prv;
   
 alloc-callback  ( a_ip -- c_addr )      gforth  alloc_callback  alloc-callback  ( a_ip -- c_addr )      gforth  alloc_callback
 c_addr = (char *)alloc_callback(engine_callback, (Xt *)a_ip);  c_addr = (char *)alloc_callback(gforth_callback, (Xt *)a_ip);
   
 va-start-void   ( -- )  gforth  va_start_void  va-start-void   ( -- )  gforth  va_start_void
 va_start_void(clist);  va_start_void(gforth_clist);
   
 va-start-int    ( -- )  gforth  va_start_int  va-start-int    ( -- )  gforth  va_start_int
 va_start_int(clist);  va_start_int(gforth_clist);
   
 va-start-longlong       ( -- )  gforth  va_start_longlong  va-start-longlong       ( -- )  gforth  va_start_longlong
 va_start_longlong(clist);  va_start_longlong(gforth_clist);
   
 va-start-ptr    ( -- )  gforth  va_start_ptr  va-start-ptr    ( -- )  gforth  va_start_ptr
 va_start_ptr(clist, (char *));  va_start_ptr(gforth_clist, (char *));
   
 va-start-float  ( -- )  gforth  va_start_float  va-start-float  ( -- )  gforth  va_start_float
 va_start_float(clist);  va_start_float(gforth_clist);
   
 va-start-double ( -- )  gforth  va_start_double  va-start-double ( -- )  gforth  va_start_double
 va_start_double(clist);  va_start_double(gforth_clist);
   
 va-arg-int      ( -- w )        gforth  va_arg_int  va-arg-int      ( -- w )        gforth  va_arg_int
 w = va_arg_int(clist);  w = va_arg_int(gforth_clist);
   
 va-arg-longlong ( -- d )        gforth  va_arg_longlong  va-arg-longlong ( -- d )        gforth  va_arg_longlong
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 DLO_IS(d, va_arg_longlong(clist));  DLO_IS(d, va_arg_longlong(gforth_clist));
 DHI_IS(d, 0);  DHI_IS(d, 0);
 #else  #else
 d = va_arg_longlong(clist);  d = va_arg_longlong(gforth_clist);
 #endif  #endif
   
 va-arg-ptr      ( -- c_addr )   gforth  va_arg_ptr  va-arg-ptr      ( -- c_addr )   gforth  va_arg_ptr
 c_addr = (char *)va_arg_ptr(clist,char*);  c_addr = (char *)va_arg_ptr(gforth_clist,char*);
   
 va-arg-float    ( -- r )        gforth  va_arg_float  va-arg-float    ( -- r )        gforth  va_arg_float
 r = va_arg_float(clist);  r = va_arg_float(gforth_clist);
   
 va-arg-double   ( -- r )        gforth  va_arg_double  va-arg-double   ( -- r )        gforth  va_arg_double
 r = va_arg_double(clist);  r = va_arg_double(gforth_clist);
   
 va-return-void ( -- )   gforth va_return_void  va-return-void ( -- )   gforth va_return_void
 va_return_void(clist);  va_return_void(gforth_clist);
 return 0;  return 0;
   
 va-return-int ( w -- )  gforth va_return_int  va-return-int ( w -- )  gforth va_return_int
 va_return_int(clist, w);  va_return_int(gforth_clist, w);
 return 0;  return 0;
   
 va-return-ptr ( c_addr -- )     gforth va_return_ptr  va-return-ptr ( c_addr -- )     gforth va_return_ptr
 va_return_ptr(clist, void *, c_addr);  va_return_ptr(gforth_clist, void *, c_addr);
 return 0;  return 0;
   
 va-return-longlong ( d -- )     gforth va_return_longlong  va-return-longlong ( d -- )     gforth va_return_longlong
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 va_return_longlong(clist, d.lo);  va_return_longlong(gforth_clist, d.lo);
 #else  #else
 va_return_longlong(clist, d);  va_return_longlong(gforth_clist, d);
 #endif  #endif
 return 0;  return 0;
   
 va-return-float ( r -- )        gforth va_return_float  va-return-float ( r -- )        gforth va_return_float
 va_return_float(clist, r);  va_return_float(gforth_clist, r);
 return 0;  return 0;
   
 va-return-double ( r -- )       gforth va_return_double  va-return-double ( r -- )       gforth va_return_double
 va_return_double(clist, r);  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
   #ifdef BUGGY_LONG_LONG
   *(Cell*)(gforth_ritem) = DLO(n);
   #else
   *(Cell*)(gforth_ritem) = n;
   #endif
   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;  return 0;
   
 \+  \+

Removed from v.1.174  
changed lines
  Added in v.1.195


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