Diff for /gforth/prim between versions 1.199 and 1.225

version 1.199, 2006/10/22 20:45:34 version 1.225, 2008/04/19 19:15:14
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 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) */
   
Line 248  SET_IP((Xt *)a_callee); Line 261  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 345  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 354  $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 371  $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 609  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 702  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 731  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 809  n = n1*n2; Line 795  n = n1*n2;
   
 /       ( n1 n2 -- n )          core    slash  /       ( n1 n2 -- n )          core    slash
 n = n1/n2;  n = n1/n2;
 if (CHECK_DIVISION && n2 == 0)  if (CHECK_DIVISION_SW && n2 == 0)
   throw(BALL_DIVZERO);    throw(BALL_DIVZERO);
 if (CHECK_DIVISION && n2 == -1 && n1 == CELL_MIN)  if (CHECK_DIVISION_SW && n2 == -1 && n1 == CELL_MIN)
   throw(BALL_RESULTRANGE);    throw(BALL_RESULTRANGE);
 if (FLOORED_DIV && ((n1^n2) < 0) && (n1%n2 != 0))  if (FLOORED_DIV && ((n1^n2) < 0) && (n1%n2 != 0))
   n--;    n--;
Line 820  if (FLOORED_DIV && ((n1^n2) < 0) && (n1% Line 806  if (FLOORED_DIV && ((n1^n2) < 0) && (n1%
   
 mod     ( n1 n2 -- n )          core  mod     ( n1 n2 -- n )          core
 n = n1%n2;  n = n1%n2;
 if (CHECK_DIVISION && n2 == 0)  if (CHECK_DIVISION_SW && n2 == 0)
   throw(BALL_DIVZERO);    throw(BALL_DIVZERO);
 if (CHECK_DIVISION && n2 == -1 && n1 == CELL_MIN)  if (CHECK_DIVISION_SW && n2 == -1 && n1 == CELL_MIN)
   throw(BALL_RESULTRANGE);    throw(BALL_RESULTRANGE);
 if(FLOORED_DIV && ((n1^n2) < 0) && n!=0) n += n2;  if(FLOORED_DIV && ((n1^n2) < 0) && n!=0) n += n2;
 :  :
Line 831  if(FLOORED_DIV && ((n1^n2) < 0) && n!=0) Line 817  if(FLOORED_DIV && ((n1^n2) < 0) && n!=0)
 /mod    ( n1 n2 -- n3 n4 )              core            slash_mod  /mod    ( n1 n2 -- n3 n4 )              core            slash_mod
 n4 = n1/n2;  n4 = n1/n2;
 n3 = n1%n2; /* !! is this correct? look into C standard! */  n3 = n1%n2; /* !! is this correct? look into C standard! */
 if (CHECK_DIVISION && n2 == 0)  if (CHECK_DIVISION_SW && n2 == 0)
   throw(BALL_DIVZERO);    throw(BALL_DIVZERO);
 if (CHECK_DIVISION && n2 == -1 && n1 == CELL_MIN)  if (CHECK_DIVISION_SW && n2 == -1 && n1 == CELL_MIN)
   throw(BALL_RESULTRANGE);    throw(BALL_RESULTRANGE);
 if (FLOORED_DIV && ((n1^n2) < 0) && n3!=0) {  if (FLOORED_DIV && ((n1^n2) < 0) && n3!=0) {
   n4--;    n4--;
Line 849  DCell d = mmul(n1,n2); Line 835  DCell d = mmul(n1,n2);
 #else  #else
 DCell d = (DCell)n1 * (DCell)n2;  DCell d = (DCell)n1 * (DCell)n2;
 #endif  #endif
 #ifdef BUGGY_LL_DIV  #ifdef ASM_SM_SLASH_REM
 DCell r = fmdiv(d,n3);  ASM_SM_SLASH_REM(DLO(d), DHI(d), n3, n4, n5);
 n4=DHI(r);  
 n5=DLO(r);  
 #else  
 /* assumes that the processor uses either floored or symmetric division */  
 DCell d5 = d/n3;  
 n4 = d%n3;  
 if (CHECK_DIVISION && n3 == 0)  
   throw(BALL_DIVZERO);  
 if (FLOORED_DIV && ((DHI(d)^n3)<0) && n4!=0) {  if (FLOORED_DIV && ((DHI(d)^n3)<0) && n4!=0) {
   d5--;    if (CHECK_DIVISION && n5 == CELL_MIN)
       throw(BALL_RESULTRANGE);
     n5--;
   n4+=n3;    n4+=n3;
 }  }
 n5 = d5;  #else
 if (d5 != n5)  DCell r = FLOORED_DIV ? fmdiv(d,n3) : smdiv(d,n3);
   throw(BALL_RESULTRANGE);  n4=DHI(r);
   n5=DLO(r);
 #endif  #endif
 :  :
  >r m* r> fm/mod ;   >r m* r> fm/mod ;
Line 877  DCell d = mmul(n1,n2); Line 858  DCell d = mmul(n1,n2);
 #else  #else
 DCell d = (DCell)n1 * (DCell)n2;  DCell d = (DCell)n1 * (DCell)n2;
 #endif  #endif
 #ifdef BUGGY_LL_DIV  #ifdef ASM_SM_SLASH_REM
 DCell r = fmdiv(d,n3);  Cell remainder;
 n4=DLO(r);  ASM_SM_SLASH_REM(DLO(d), DHI(d), n3, remainder, n4);
   if (FLOORED_DIV && ((DHI(d)^n3)<0) && remainder!=0) {
     if (CHECK_DIVISION && n4 == CELL_MIN)
       throw(BALL_RESULTRANGE);
     n4--;
   }
 #else  #else
 /* assumes that the processor uses either floored or symmetric division */  DCell r = FLOORED_DIV ? fmdiv(d,n3) : smdiv(d,n3);
 DCell d4 = d/n3;  n4=DLO(r);
 if (CHECK_DIVISION && n3 == 0)  
   throw(BALL_DIVZERO);  
 if (FLOORED_DIV && ((DHI(d)^n3)<0) && (d%n3)!=0)  
   d4--;  
 n4 = d4;  
 if (d4 != n4)  
   throw(BALL_RESULTRANGE);  
 #endif  #endif
 :  :
  */mod nip ;   */mod nip ;
Line 913  n2 = n1>>1; Line 892  n2 = n1>>1;
   
 fm/mod  ( d1 n1 -- n2 n3 )              core            f_m_slash_mod  fm/mod  ( d1 n1 -- n2 n3 )              core            f_m_slash_mod
 ""Floored division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, @i{n1}>@i{n2}>=0 or 0>=@i{n2}>@i{n1}.""  ""Floored division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, @i{n1}>@i{n2}>=0 or 0>=@i{n2}>@i{n1}.""
 #ifdef BUGGY_LL_DIV  
 #ifdef ASM_SM_SLASH_REM  #ifdef ASM_SM_SLASH_REM
 ASM_SM_SLASH_REM(d1.lo, d1.hi, n1, n2, n3);  ASM_SM_SLASH_REM(DLO(d1), DHI(d1), n1, n2, n3);
 if (((DHI(d1)^n1)<0) && n2!=0) {  if (((DHI(d1)^n1)<0) && n2!=0) {
   if (n3 == CELL_MIN)    if (CHECK_DIVISION && n3 == CELL_MIN)
     throw(BALL_RESULTRANGE);      throw(BALL_RESULTRANGE);
   n3--;    n3--;
   n2+=n1;    n2+=n1;
Line 927  DCell r = fmdiv(d1,n1); Line 905  DCell r = fmdiv(d1,n1);
 n2=DHI(r);  n2=DHI(r);
 n3=DLO(r);  n3=DLO(r);
 #endif /* !defined(ASM_SM_SLASH_REM) */  #endif /* !defined(ASM_SM_SLASH_REM) */
 #else  
 #ifdef ASM_SM_SLASH_REM4  
 ASM_SM_SLASH_REM4(d1, n1, n2, n3);  
 if (((DHI(d1)^n1)<0) && n2!=0) {  
   if (n3 == CELL_MIN)  
     throw(BALL_RESULTRANGE);  
   n3--;  
   n2+=n1;  
 }  
 #else /* !defined(ASM_SM_SLASH_REM4) */  
 /* assumes that the processor uses either floored or symmetric division */  
 DCell d3 = d1/n1;  
 n2 = d1%n1;  
 if (CHECK_DIVISION && n1 == 0)  
   throw(BALL_DIVZERO);  
 /* note that this 1%-3>0 is optimized by the compiler */  
 if (1%-3>0 && ((DHI(d1)^n1)<0) && n2!=0) {  
   d3--;  
   n2+=n1;  
 }  
 n3 = d3;  
 if (d3 != n3)  
   throw(BALL_RESULTRANGE);  
 #endif /* !defined(ASM_SM_SLASH_REM4) */  
 #endif  
 :  :
  dup >r dup 0< IF  negate >r dnegate r>  THEN   dup >r dup 0< IF  negate >r dnegate r>  THEN
  over       0< IF  tuck + swap  THEN   over       0< IF  tuck + swap  THEN
Line 960  if (d3 != n3) Line 913  if (d3 != n3)
   
 sm/rem  ( d1 n1 -- n2 n3 )              core            s_m_slash_rem  sm/rem  ( d1 n1 -- n2 n3 )              core            s_m_slash_rem
 ""Symmetric division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, sign(@i{n2})=sign(@i{d1}) or 0.""  ""Symmetric division: @i{d1} = @i{n3}*@i{n1}+@i{n2}, sign(@i{n2})=sign(@i{d1}) or 0.""
 #ifdef BUGGY_LL_DIV  
 #ifdef ASM_SM_SLASH_REM  #ifdef ASM_SM_SLASH_REM
 ASM_SM_SLASH_REM(d1.lo, d1.hi, n1, n2, n3);  ASM_SM_SLASH_REM(DLO(d1), DHI(d1), n1, n2, n3);
 #else /* !defined(ASM_SM_SLASH_REM) */  #else /* !defined(ASM_SM_SLASH_REM) */
 DCell r = smdiv(d1,n1);  DCell r = smdiv(d1,n1);
 n2=DHI(r);  n2=DHI(r);
 n3=DLO(r);  n3=DLO(r);
 #endif /* !defined(ASM_SM_SLASH_REM) */  #endif /* !defined(ASM_SM_SLASH_REM) */
 #else  
 #ifdef ASM_SM_SLASH_REM4  
 ASM_SM_SLASH_REM4(d1, n1, n2, n3);  
 #else /* !defined(ASM_SM_SLASH_REM4) */  
 /* assumes that the processor uses either floored or symmetric division */  
 DCell d3 = d1/n1;  
 n2 = d1%n1;  
 if (CHECK_DIVISION && n1 == 0)  
   throw(BALL_DIVZERO);  
 /* note that this 1%-3<0 is optimized by the compiler */  
 if (1%-3<0 && ((DHI(d1)^n1)<0) && n2!=0) {  
   d3++;  
   n2-=n1;  
 }  
 n3 = d3;  
 if (d3 != n3)  
   throw(BALL_RESULTRANGE);  
 #endif /* !defined(ASM_SM_SLASH_REM4) */  
 #endif  
 :  :
  over >r dup >r abs -rot   over >r dup >r abs -rot
  dabs rot um/mod   dabs rot um/mod
Line 1022  ud = (UDCell)u1 * (UDCell)u2; Line 955  ud = (UDCell)u1 * (UDCell)u2;
   
 um/mod  ( ud u1 -- u2 u3 )              core    u_m_slash_mod  um/mod  ( ud u1 -- u2 u3 )              core    u_m_slash_mod
 ""ud=u3*u1+u2, u1>u2>=0""  ""ud=u3*u1+u2, u1>u2>=0""
 #ifdef BUGGY_LL_DIV  
 #ifdef ASM_UM_SLASH_MOD  #ifdef ASM_UM_SLASH_MOD
 ASM_UM_SLASH_MOD(ud.lo, ud.hi, u1, u2, u3);  ASM_UM_SLASH_MOD(DLO(ud), DHI(ud), u1, u2, u3);
 #else /* !defined(ASM_UM_SLASH_MOD) */  #else /* !defined(ASM_UM_SLASH_MOD) */
 UDCell r = umdiv(ud,u1);  UDCell r = umdiv(ud,u1);
 u2=DHI(r);  u2=DHI(r);
 u3=DLO(r);  u3=DLO(r);
 #endif /* !defined(ASM_UM_SLASH_MOD) */  #endif /* !defined(ASM_UM_SLASH_MOD) */
 #else  
 #ifdef ASM_UM_SLASH_MOD4  
 ASM_UM_SLASH_MOD4(ud, u1, u2, u3);  
 #else /* !defined(ASM_UM_SLASH_MOD4) */  
 UDCell ud3 = ud/u1;  
 u2 = ud%u1;  
 if (CHECK_DIVISION && u1 == 0)  
   throw(BALL_DIVZERO);  
 u3 = ud3;  
 if (ud3 != u3)  
   throw(BALL_RESULTRANGE);  
 #endif /* !defined(ASM_UM_SLASH_MOD4) */  
 #endif  
 :  :
    0 swap [ 8 cells 1 + ] literal 0     0 swap [ 8 cells 1 + ] literal 0
    ?DO /modstep     ?DO /modstep
Line 1095  d2 = -d1; Line 1014  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 1559  for (; f83name1 != NULL; f83name1 = (str Line 1473  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 1714  f = key_query((FILE*)wfileid); Line 1633  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 1728  stderr ( -- wfileid ) gforth Line 1645  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 1801  nhour =ltime->tm_hour; Line 1725  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 1853  u = strlen((char *)c_addr); Line 1774  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 */
 gforth_FP=fp;  gforth_FP=fp;
Line 1869  close-file ( wfileid -- wior )  file clo Line 1790  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 2196  floor ( r1 -- r2 ) float Line 2108  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 2481  r = fp[u]; Line 2393  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)  #if 1
   u2 = (UCell)lt_dlopenadvise(cstr(c_addr1, u1, 1), ltdl_advice);
   #elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
 #ifndef RTLD_GLOBAL  #ifndef RTLD_GLOBAL
 #define RTLD_GLOBAL 0  #define RTLD_GLOBAL 0
 #endif  #endif
Line 2496  u2 = 0; Line 2410  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)  #if 1
   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 2833  define(`uploop', Line 2749  define(`uploop',
 define(`_uploop',  define(`_uploop',
        `ifelse($1, `$3', `$5',         `ifelse($1, `$3', `$5',
                `$4`'define(`$1', incr($1))_uploop(`$1', `$2', `$3', `$4', `$5')')')                 `$4`'define(`$1', incr($1))_uploop(`$1', `$2', `$3', `$4', `$5')')')
   
 \ argflist(argnum): Forth argument list  \ argflist(argnum): Forth argument list
 define(argflist,  define(argflist,
        `ifelse($1, 0, `',         `ifelse($1, 0, `',
                `uploop(`_i', 1, $1, `format(`u%d ', _i)', `format(`u%d ', _i)')')')                 `uploop(`_i', 1, $1, ``u''`_i ', ``u''`_i')')')
 \ argdlist(argnum): declare C's arguments  \ argdlist(argnum): declare C's arguments
 define(argdlist,  define(argdlist,
        `ifelse($1, 0, `',         `ifelse($1, 0, `',
Line 2844  define(argdlist, Line 2761  define(argdlist,
 \ argclist(argnum): pass C's arguments  \ argclist(argnum): pass C's arguments
 define(argclist,  define(argclist,
        `ifelse($1, 0, `',         `ifelse($1, 0, `',
                `uploop(`_i', 1, $1, `format(`u%d, ', _i)', `format(`u%d', _i)')')')                 `uploop(`_i', 1, $1, ``u''`_i, ', ``u''`_i')')')
 \ icall(argnum)  \ icall(argnum)
 define(icall,  define(icall,
 `icall$1        ( argflist($1)u -- uret )       gforth  `icall$1        ( argflist($1) u -- uret )      gforth
 uret = (SYSCALL(Cell(*)(argdlist($1)))u)(argclist($1));  uret = (SYSCALL(Cell(*)(argdlist($1)))u)(argclist($1));
   
 ')  ')
 define(fcall,  define(fcall,
 `fcall$1        ( argflist($1)u -- rret )       gforth  `fcall$1        ( argflist($1) u -- rret )      gforth
 rret = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1));  rret = (SYSCALL(Float(*)(argdlist($1)))u)(argclist($1));
   
 ')  ')
Line 2865  uploop(i, 0, 7, `fcall(i)') Line 2782  uploop(i, 0, 7, `fcall(i)')
 fcall(20)  fcall(20)
   
 \+  \+
 \+  
   
   lib-error ( -- c_addr u )       gforth  lib_error
   c_addr = lt_dlerror();
   u = (c_addr == NULL) ? 0 : strlen(c_addr);
   
   \+
 \g peephole  \g peephole
   
 \+peephole  \+peephole

Removed from v.1.199  
changed lines
  Added in v.1.225


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