Diff for /gforth/prim between versions 1.187 and 1.191

version 1.187, 2006/01/29 18:34:33 version 1.191, 2006/03/11 23:05:09
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 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
 gforth_UP=up=(char *)a_addr;  gforth_UP=up=(Address)a_addr;
 :  :
  up ! ;   up ! ;
 Variable UP  Variable UP
Line 1672  with the window size."" Line 1681  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 1711  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 1788  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 1916  if(dent == NULL) { Line 1929  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 1954  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 1974  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 2153  sig=ecvt(r, u, &decpt, &flag); Line 2166  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 2574  alloc-callback ( a_ip -- c_addr ) gforth Line 2587  alloc-callback ( a_ip -- c_addr ) gforth
 c_addr = (char *)alloc_callback(gforth_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;  return 0;
   
 \+  \+
Line 2660  static int ffi_sizes[] = Line 2673  static int ffi_sizes[] =
 n2 = ffi_sizes[n1];  n2 = ffi_sizes[n1];
   
 ffi-prep-cif ( a_atypes n a_rtype a_cif -- w )  gforth ffi_prep_cif  ffi-prep-cif ( a_atypes n a_rtype a_cif -- w )  gforth ffi_prep_cif
 w = ffi_prep_cif(a_cif, FFI_DEFAULT_ABI, n, a_rtype, a_atypes);  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  ffi-call ( a_avalues a_rvalue a_ip a_cif -- )   gforth ffi_call
 SAVE_REGS  SAVE_REGS
 ffi_call(a_cif, a_ip, a_rvalue, a_avalues);  ffi_call((ffi_cif *)a_cif, (void(*)())a_ip, (void *)a_rvalue, (void **)a_avalues);
 REST_REGS  REST_REGS
   
 ffi-prep-closure ( a_ip a_cif a_closure -- w )  gforth ffi_prep_closure  ffi-prep-closure ( a_ip a_cif a_closure -- w )  gforth ffi_prep_closure
 w = ffi_prep_closure(a_closure, a_cif, gforth_callback, a_ip);  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  ffi-2@ ( a_addr -- d )  gforth ffi_2fetch
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
Line 2686  ffi-2! ( d a_addr -- ) gforth ffi_2store Line 2700  ffi-2! ( d a_addr -- ) gforth ffi_2store
 #endif  #endif
   
 ffi-arg-int ( -- w )    gforth ffi_arg_int  ffi-arg-int ( -- w )    gforth ffi_arg_int
 w = *(int *)(*clist++);  w = *(int *)(*gforth_clist++);
   
 ffi-arg-longlong ( -- d )       gforth ffi_arg_longlong  ffi-arg-longlong ( -- d )       gforth ffi_arg_longlong
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 DLO_IS(d, (Cell*)(*clist++));  DLO_IS(d, (Cell*)(*gforth_clist++));
 DHI_IS(d, 0);  DHI_IS(d, 0);
 #else  #else
 d = *(DCell*)(*clist++);  d = *(DCell*)(*gforth_clist++);
 #endif  #endif
   
 ffi-arg-ptr ( -- c_addr )       gforth ffi_arg_ptr  ffi-arg-ptr ( -- c_addr )       gforth ffi_arg_ptr
 c_addr = *(char **)(*clist++);  c_addr = *(Char **)(*gforth_clist++);
   
 ffi-arg-float ( -- r )  gforth ffi_arg_float  ffi-arg-float ( -- r )  gforth ffi_arg_float
 r = *(float*)(*clist++);  r = *(float*)(*gforth_clist++);
   
 ffi-arg-double ( -- r ) gforth ffi_arg_double  ffi-arg-double ( -- r ) gforth ffi_arg_double
 r = *(double*)(*clist++);  r = *(double*)(*gforth_clist++);
   
 ffi-ret-void ( -- )     gforth ffi_ret_void  ffi-ret-void ( -- )     gforth ffi_ret_void
 return 0;  return 0;
   
 ffi-ret-int ( w -- )    gforth ffi_ret_int  ffi-ret-int ( w -- )    gforth ffi_ret_int
 *(int*)(ritem) = w;  *(int*)(gforth_ritem) = w;
 return 0;  return 0;
   
 ffi-ret-longlong ( d -- )       gforth ffi_ret_longlong  ffi-ret-longlong ( d -- )       gforth ffi_ret_longlong
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
 *(Cell*)(ritem) = DLO(d);  *(Cell*)(gforth_ritem) = DLO(d);
 #else  #else
 *(DCell*)(ritem) = d;  *(DCell*)(gforth_ritem) = d;
 #endif  #endif
 return 0;  return 0;
   
 ffi-ret-ptr ( c_addr -- )       gforth ffi_ret_ptr  ffi-ret-ptr ( c_addr -- )       gforth ffi_ret_ptr
 *(char **)(ritem) = c_addr;  *(Char **)(gforth_ritem) = c_addr;
 return 0;  return 0;
   
 ffi-ret-float ( r -- )  gforth ffi_ret_float  ffi-ret-float ( r -- )  gforth ffi_ret_float
 *(float*)(ritem) = r;  *(float*)(gforth_ritem) = r;
 return 0;  return 0;
   
 ffi-ret-double ( r -- ) gforth ffi_ret_double  ffi-ret-double ( r -- ) gforth ffi_ret_double
 *(double*)(ritem) = r;  *(double*)(gforth_ritem) = r;
 return 0;  return 0;
   
 \+  \+

Removed from v.1.187  
changed lines
  Added in v.1.191


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