Diff for /gforth/prim between versions 1.231 and 1.256

version 1.231, 2008/07/27 09:58:29 version 1.256, 2010/09/01 16:52:12
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 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 1662  ucols=cols; Line 1699  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 1674  supported on your machine (take a look a Line 1715  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 1694  c_addr2 = (Char *)getenv(cstr(c_addr1,u1 Line 1735  c_addr2 = (Char *)getenv(cstr(c_addr1,u1
 u2 = (c_addr2 == NULL ? 0 : strlen((char *)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
   fflush(stdout);
 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? */
 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 */
   
Line 1782  gforth_FP=fp; Line 1824  gforth_FP=fp;
 gforth_SP=sp;  gforth_SP=sp;
 gforth_RP=rp;  gforth_RP=rp;
 gforth_LP=lp;  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;  rp=gforth_RP;
Line 1827  wior = IOR(ftruncate(fileno((FILE *)wfil Line 1873  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 1925  Return an error if this is not possible" Line 1973  Return an error if this is not possible"
 wior = IOR(chdir(tilde_cstr(c_addr, u, 1)));  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 @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 1934  if(c_addr2 != NULL) { Line 1982  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}.""
   wior = IOR(mkdir(tilde_cstr(c_addr,u,1),wmode));
   
 \+  \+
   
 newline ( -- c_addr u ) gforth  newline ( -- c_addr u ) gforth
Line 2137  int flag; Line 2189  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 2399  r = fp[u]; Line 2452  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 1  u2 = gforth_dlopen(c_addr1, u1);
 u2 = (UCell)lt_dlopen(tilde_cstr(c_addr1, u1, 1));  
 #elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)  
 #ifndef RTLD_GLOBAL  
 #define RTLD_GLOBAL 0  
 #endif  
 u2=(UCell) dlopen(tilde_cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);  
 #else  
 #  ifdef _WIN32  
 u2 = (Cell) GetModuleHandle(tilde_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 1  #ifdef HAVE_LIBLTDL
 u3 = (UCell) lt_dlsym((lt_dlhandle)u2, cstr(c_addr1, u1, 1));  u3 = (UCell) lt_dlsym((lt_dlhandle)u2, cstr(c_addr1, u1, 1));
 #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,cstr(c_addr1, u1, 1));
Line 2460  l! ( w c_addr -- ) gforth l_store Line 2499  l! ( w c_addr -- ) gforth l_store
   
 lib-error ( -- c_addr u )       gforth  lib_error  lib-error ( -- c_addr u )       gforth  lib_error
 ""Error message for last failed @code{open-lib} or @code{lib-sym}.""  ""Error message for last failed @code{open-lib} or @code{lib-sym}.""
 c_addr = lt_dlerror();  #ifdef HAVE_LIBLTDL
 u = (c_addr == NULL) ? 0 : strlen(c_addr);  c_addr = (Char *)lt_dlerror();
   u = (c_addr == NULL) ? 0 : strlen((char *)c_addr);
   #elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
   c_addr = dlerror();
   u = strlen(c_addr);
   #else
   c_addr = "libltdl is not configured";
   u = strlen(c_addr);
   #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 = (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 = (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 2510  a_addr = groups; Line 2656  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.231  
changed lines
  Added in v.1.256


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