Diff for /gforth/prim between versions 1.203 and 1.249

version 1.203, 2006/10/30 16:20:41 version 1.249, 2010/05/02 16:21:32
Line 1 Line 1
 \ Gforth primitives  \ Gforth primitives
   
 \ Copyright (C) 1995,1996,1997,1998,2000,2003,2004,2005 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.
   
 \ 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
 a_retaddr = next_code;  a_retaddr = next_code;
 a_body = PFA(CFA);  a_body = PFA(CFA);
 INST_TAIL;  INST_TAIL;
   #ifdef DEBUG
   fprintf(stderr, "dodoes to %x, push %x\n", a_retaddr, a_body);
   #endif
 goto **(Label *)DOES_CODE1(CFA);  goto **(Label *)DOES_CODE1(CFA);
 #else /* !defined(NO_IP) */  #else /* !defined(NO_IP) */
 a_retaddr = (Cell *)IP;  a_retaddr = (Cell *)IP;
 a_body = PFA(CFA);  a_body = PFA(CFA);
   #ifdef DEBUG
   fprintf(stderr, "dodoes to %x, push %x\n", a_retaddr, a_body);
   #endif
 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 248  SET_IP((Xt *)a_callee); Line 280  SET_IP((Xt *)a_callee);
   
 execute ( xt -- )               core  execute ( xt -- )               core
 ""Perform the semantics represented by the execution token, @i{xt}.""  ""Perform the semantics represented by the execution token, @i{xt}.""
   #ifdef DEBUG
   fprintf(stderr, "execute %08x\n", xt);
   #endif
 #ifndef NO_IP  #ifndef NO_IP
 ip=IP;  ip=IP;
 #endif  #endif
Line 329  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 340  $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 355  $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 626  i' ( R:w R:w2 -- R:w R:w2 w )  gforth  i Line 628  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 719  c2 = toupper(c1); Line 721  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 748  n = n1+n2; Line 750  n = n1+n2;
 \ lit+ / lit_plus = lit +  \ lit+ / lit_plus = lit +
   
 lit+    ( n1 #n2 -- n )         new     lit_plus  lit+    ( n1 #n2 -- n )         new     lit_plus
   #ifdef DEBUG
   fprintf(stderr, "lit+ %08x\n", n2);
   #endif
 n=n1+n2;  n=n1+n2;
   
 \ PFE-0.9.14 has it differently, but the next release will have it as follows  \ PFE-0.9.14 has it differently, but the next release will have it as follows
Line 851  DCell d = (DCell)n1 * (DCell)n2; Line 856  DCell d = (DCell)n1 * (DCell)n2;
 #endif  #endif
 #ifdef ASM_SM_SLASH_REM  #ifdef ASM_SM_SLASH_REM
 ASM_SM_SLASH_REM(DLO(d), DHI(d), n3, n4, n5);  ASM_SM_SLASH_REM(DLO(d), DHI(d), n3, n4, n5);
 if (((DHI(d)^n3)<0) && n4!=0) {  if (FLOORED_DIV && ((DHI(d)^n3)<0) && n4!=0) {
   if (CHECK_DIVISION && n5 == CELL_MIN)    if (CHECK_DIVISION && n5 == CELL_MIN)
     throw(BALL_RESULTRANGE);      throw(BALL_RESULTRANGE);
   n5--;    n5--;
   n4+=n3;    n4+=n3;
 }  }
 #else  #else
 DCell r = fmdiv(d,n3);  DCell r = FLOORED_DIV ? fmdiv(d,n3) : smdiv(d,n3);
 n4=DHI(r);  n4=DHI(r);
 n5=DLO(r);  n5=DLO(r);
 #endif  #endif
Line 875  DCell d = (DCell)n1 * (DCell)n2; Line 880  DCell d = (DCell)n1 * (DCell)n2;
 #ifdef ASM_SM_SLASH_REM  #ifdef ASM_SM_SLASH_REM
 Cell remainder;  Cell remainder;
 ASM_SM_SLASH_REM(DLO(d), DHI(d), n3, remainder, n4);  ASM_SM_SLASH_REM(DLO(d), DHI(d), n3, remainder, n4);
 if (((DHI(d)^n3)<0) && remainder!=0) {  if (FLOORED_DIV && ((DHI(d)^n3)<0) && remainder!=0) {
   if (CHECK_DIVISION && n4 == CELL_MIN)    if (CHECK_DIVISION && n4 == CELL_MIN)
     throw(BALL_RESULTRANGE);      throw(BALL_RESULTRANGE);
   n4--;    n4--;
 }  }
 #else  #else
 DCell r = fmdiv(d,n3);  DCell r = FLOORED_DIV ? fmdiv(d,n3) : smdiv(d,n3);
 n4=DLO(r);  n4=DLO(r);
 #endif  #endif
 :  :
Line 1028  d2 = -d1; Line 1033  d2 = -d1;
   
 d2*     ( d1 -- d2 )            double          d_two_star  d2*     ( d1 -- d2 )            double          d_two_star
 ""Shift left by 1; also works on unsigned numbers""  ""Shift left by 1; also works on unsigned numbers""
 #ifdef BUGGY_LL_SHIFT  d2 = DLSHIFT(d1,1);
 DLO_IS(d2, DLO(d1)<<1);  
 DHI_IS(d2, (DHI(d1)<<1) | (DLO(d1)>>(CELL_BITS-1)));  
 #else  
 d2 = 2*d1;  
 #endif  
 :  :
  2dup d+ ;   2dup d+ ;
   
Line 1492  for (; f83name1 != NULL; f83name1 = (str Line 1492  for (; f83name1 != NULL; f83name1 = (str
       memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)        memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
     break;      break;
 f83name2=f83name1;  f83name2=f83name1;
   #ifdef DEBUG
   fprintf(stderr, "F83find ");
   fwrite(c_addr, u, 1, stderr);
   fprintf(stderr, " found %08x\n", f83name2); 
   #endif
 :  :
     BEGIN  dup WHILE  (find-samelen)  dup  WHILE      BEGIN  dup WHILE  (find-samelen)  dup  WHILE
         >r 2dup r@ cell+ char+ capscomp  0=          >r 2dup r@ cell+ char+ capscomp  0=
Line 1647  f = key_query((FILE*)wfileid); Line 1652  f = key_query((FILE*)wfileid);
 f = key_query(stdin);  f = key_query(stdin);
 #endif  #endif
   
 \+os  
   
 stdin   ( -- wfileid )  gforth  stdin   ( -- wfileid )  gforth
 ""The standard input file of the Gforth process.""  ""The standard input file of the Gforth process.""
 wfileid = (Cell)stdin;  wfileid = (Cell)stdin;
Line 1661  stderr ( -- wfileid ) gforth Line 1664  stderr ( -- wfileid ) gforth
 ""The standard error output file of the Gforth process.""  ""The standard error output file of the Gforth process.""
 wfileid = (Cell)stderr;  wfileid = (Cell)stderr;
   
   \+os
   
 form    ( -- urows ucols )      gforth  form    ( -- urows ucols )      gforth
 ""The number of lines and columns in the terminal. These numbers may change  ""The number of lines and columns in the terminal. These numbers may
 with the window size.""  change with the window size.  Note that it depends on the OS whether
   this reflects the actual size and changes with the window size
   (currently only on Unix-like OSs).  On other OSs you just get a
   default, and can tell Gforth the terminal size by setting the
   environment variables @code{COLUMNS} and @code{LINES} before starting
   Gforth.""
 /* we could block SIGWINCH here to get a consistent size, but I don't  /* we could block SIGWINCH here to get a consistent size, but I don't
  think this is necessary or always beneficial */   think this is necessary or always beneficial */
 urows=rows;  urows=rows;
Line 1671  ucols=cols; Line 1681  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 1683  supported on your machine (take a look a Line 1697  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 1703  c_addr2 = (Char *)getenv(cstr(c_addr1,u1 Line 1717  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 1734  nhour =ltime->tm_hour; Line 1749  nhour =ltime->tm_hour;
 nmin  =ltime->tm_min;  nmin  =ltime->tm_min;
 nsec  =ltime->tm_sec;  nsec  =ltime->tm_sec;
   
 ms      ( n -- )        facility-ext  ms      ( u -- )        facility-ext
 ""Wait at least @i{n} milli-second.""  ""Wait at least @i{n} milli-second.""
 struct timeval timeout;  gforth_ms(u);
 timeout.tv_sec=n/1000;  
 timeout.tv_usec=1000*(n%1000);  
 (void)select(0,0,0,0,&timeout);  
   
 allocate        ( u -- a_addr wior )    memory  allocate        ( u -- a_addr wior )    memory
 ""Allocate @i{u} address units of contiguous data space. The initial  ""Allocate @i{u} address units of contiguous data space. The initial
Line 1786  u = strlen((char *)c_addr); Line 1798  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
 access the stack itself. The stack pointers are exported in the global  access the stack itself. The stack pointers are exported in the global
 variables @code{SP} and @code{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 1802  close-file ( wfileid -- wior )  file clo Line 1824  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]);  wfileid = opencreate_file(tilde_cstr(c_addr,u,1), wfam, 0, &wior);
 wior =  IOR(wfileid == 0);  
   
 create-file     ( c_addr u wfam -- wfileid wior )       file    create_file  create-file     ( c_addr u wfam -- wfileid wior )       file    create_file
 Cell    fd;  wfileid = opencreate_file(tilde_cstr(c_addr,u,1), wfam, O_CREAT|O_TRUNC, &wior);
 fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[wfam], 0666);  
 if (fd != -1) {  
   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);  wior = IOR(unlink(tilde_cstr(c_addr, u, 1))==-1);
Line 1842  wior = IOR(ftruncate(fileno((FILE *)wfil Line 1855  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 1940  Return an error if this is not possible" Line 1955  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 1949  if(c_addr2 != NULL) { Line 1964  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 2129  floor ( r1 -- r2 ) float Line 2148  floor ( r1 -- r2 ) float
 /* !! unclear wording */  /* !! unclear wording */
 r2 = floor(r1);  r2 = floor(r1);
   
 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 2152  int flag; Line 2171  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 2414  r = fp[u]; Line 2434  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)  #ifdef HAVE_LIBLTDL
   u3 = (UCell) lt_dlsym((lt_dlhandle)u2, cstr(c_addr1, u1, 1));
   #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));
 #else  #else
 #  ifdef _WIN32  #  ifdef _WIN32
Line 2469  l! ( w c_addr -- ) gforth l_store Line 2479  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  
 av_start_float(alist, c_addr, &frv);  
   
 av-start-double ( c_addr -- )   gforth  av_start_double  
 av_start_double(alist, c_addr, &drv);  
   
 av-start-longlong       ( c_addr -- )   gforth  av_start_longlong  
 av_start_longlong(alist, c_addr, &llrv);  
   
 av-start-ptr    ( c_addr -- )   gforth  av_start_ptr  
 av_start_ptr(alist, c_addr, void*, &prv);  
   
 av-int  ( w -- )  gforth  av_int  
 av_int(alist, w);  
   
 av-float        ( r -- )        gforth  av_float  
 av_float(alist, r);  
   
 av-double       ( r -- )        gforth  av_double  
 av_double(alist, r);  
   
 av-longlong     ( d -- )        gforth  av_longlong  
 #ifdef BUGGY_LL_SIZE  
 av_longlong(alist, DLO(d));  
 #else  #else
 av_longlong(alist, d);  c_addr = "libltdl is not configured";
   u = strlen(c_addr);
 #endif  #endif
   
 av-ptr  ( c_addr -- )   gforth  av_ptr  
 av_ptr(alist, void*, c_addr);  
   
 av-int-r  ( R:w -- )  gforth  av_int_r  
 av_int(alist, w);  
   
 av-float-r      ( -- )  gforth  av_float_r  
 float r = *(Float*)lp;  
 lp += sizeof(Float);  
 av_float(alist, r);  
   
 av-double-r     ( -- )  gforth  av_double_r  
 double r = *(Float*)lp;  
 lp += sizeof(Float);  
 av_double(alist, r);  
   
 av-longlong-r   ( R:d -- )      gforth  av_longlong_r  
 #ifdef BUGGY_LL_SIZE  
 av_longlong(alist, DLO(d));  
 #else  
 av_longlong(alist, d);  
 #endif  
   
 av-ptr-r        ( R:c_addr -- ) gforth  av_ptr_r  
 av_ptr(alist, void*, c_addr);  
   
 av-call-void    ( ... -- ... )  gforth  av_call_void  
 SAVE_REGS  
 av_call(alist);  
 REST_REGS  
   
 av-call-int     ( ... -- ... w )        gforth  av_call_int  
 SAVE_REGS  
 av_call(alist);  
 REST_REGS  
 w = irv;  
   
 av-call-float   ( ... -- ... r )        gforth  av_call_float  
 SAVE_REGS  
 av_call(alist);  
 REST_REGS  
 r = frv;  
   
 av-call-double  ( ... -- ... r )        gforth  av_call_double  
 SAVE_REGS  
 av_call(alist);  
 REST_REGS  
 r = drv;  
   
 av-call-longlong        ( ... -- ... d )        gforth  av_call_longlong  
 SAVE_REGS  
 av_call(alist);  
 REST_REGS  
 #ifdef BUGGY_LONG_LONG  
 DLO_IS(d, llrv);  
 DHI_IS(d, 0);  
 #else  
 d = llrv;  
 #endif  
   
 av-call-ptr     ( ... -- ... c_addr )   gforth  av_call_ptr  
 SAVE_REGS  
 av_call(alist);  
 REST_REGS  
 c_addr = prv;  
   
 alloc-callback  ( a_ip -- c_addr )      gforth  alloc_callback  
 c_addr = (char *)alloc_callback(gforth_callback, (Xt *)a_ip);  
   
 va-start-void   ( -- )  gforth  va_start_void  
 va_start_void(gforth_clist);  
   
 va-start-int    ( -- )  gforth  va_start_int  
 va_start_int(gforth_clist);  
   
 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, `format(`u%d ', _i)', `format(`u%d ', _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, `format(`u%d, ', _i)', `format(`u%d', _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 2846  a_addr = groups; Line 2539  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.203  
changed lines
  Added in v.1.249


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