Diff for /gforth/prim between versions 1.150 and 1.200

version 1.150, 2004/01/25 12:35:58 version 1.200, 2006/10/27 21:47:01
Line 1 Line 1
 \ Gforth primitives  \ Gforth primitives
   
 \ Copyright (C) 1995,1996,1997,1998,2000,2003 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 100 Line 100
 \E s" struct F83Name *" single data-stack type-prefix f83name  \E s" struct F83Name *" single data-stack type-prefix f83name
 \E s" struct Longname *" single data-stack type-prefix longname  \E s" struct Longname *" single data-stack type-prefix longname
 \E   \E 
   \E data-stack   stack-prefix S:
   \E fp-stack     stack-prefix F:
 \E return-stack stack-prefix R:  \E return-stack stack-prefix R:
 \E inst-stream  stack-prefix #  \E inst-stream  stack-prefix #
 \E   \E 
Line 138 Line 140
   
 \ Stack caching setup  \ Stack caching setup
   
 ifdef(`M4_ENGINE_FAST', `include(cache1.vmg)', `include(cache0.vmg)')  ifdef(`STACK_CACHE_FILE', `include(STACK_CACHE_FILE)', `include(cache0.vmg)')
   
 \ these m4 macros would collide with identifiers  \ these m4 macros would collide with identifiers
 undefine(`index')  undefine(`index')
Line 191  goto *next_code; Line 193  goto *next_code;
 ip=IP; /* undo any ip updating that may have been performed by NEXT_P0 */  ip=IP; /* undo any ip updating that may have been performed by NEXT_P0 */
 #endif /* !defined(NO_IP) */  #endif /* !defined(NO_IP) */
 SUPER_END; /* !! probably unnecessary and may lead to measurement errors */  SUPER_END; /* !! probably unnecessary and may lead to measurement errors */
 EXEC(*(Xt *)PFA(CFA));  VM_JUMP(EXEC1(*(Xt *)PFA(CFA)));
   
 (dofield) ( n1 -- n2 )  gforth-internal paren_field  (dofield) ( n1 -- n2 )  gforth-internal paren_field
 ""run-time routine for fields""  ""run-time routine for fields""
Line 249  execute ( xt -- )  core Line 251  execute ( xt -- )  core
 #ifndef NO_IP  #ifndef NO_IP
 ip=IP;  ip=IP;
 #endif  #endif
 IF_spTOS(spTOS = sp[0]); /* inst_tail would produce a NEXT_P1 */  
 SUPER_END;  SUPER_END;
 EXEC(xt);  VM_JUMP(EXEC1(xt));
   
 perform ( a_addr -- )   gforth  perform ( a_addr -- )   gforth
 ""@code{@@ execute}.""  ""@code{@@ execute}.""
Line 259  perform ( a_addr -- ) gforth Line 260  perform ( a_addr -- ) gforth
 #ifndef NO_IP  #ifndef NO_IP
 ip=IP;  ip=IP;
 #endif  #endif
 IF_spTOS(spTOS = sp[0]); /* inst_tail would produce a NEXT_P1 */  
 SUPER_END;  SUPER_END;
 EXEC(*(Xt *)a_addr);  VM_JUMP(EXEC1(*(Xt *)a_addr));
 :  :
  @ execute ;   @ execute ;
   
Line 284  lit-perform ( #a_addr -- ) new lit_perfo Line 284  lit-perform ( #a_addr -- ) new lit_perfo
 ip=IP;  ip=IP;
 #endif  #endif
 SUPER_END;  SUPER_END;
 EXEC(*(Xt *)a_addr);  VM_JUMP(EXEC1(*(Xt *)a_addr));
   
 does-exec ( #a_cfa -- R:nest a_pfa )    new     does_exec  does-exec ( #a_cfa -- R:nest a_pfa )    new     does_exec
 #ifdef NO_IP  #ifdef NO_IP
Line 293  assert(0); Line 293  assert(0);
 #else  #else
 a_pfa = PFA(a_cfa);  a_pfa = PFA(a_cfa);
 nest = (Cell)IP;  nest = (Cell)IP;
 IF_spTOS(spTOS = sp[0]);  
 #ifdef DEBUG  #ifdef DEBUG
     {      {
       CFA_TO_NAME(a_cfa);        CFA_TO_NAME(a_cfa);
Line 330  SET_IP((Xt *)a_target); Line 329  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 339  $5 #ifdef NO_IP Line 340  $5 #ifdef NO_IP
 JUMP(a_target);  JUMP(a_target);
 #else  #else
 SET_IP((Xt *)a_target);  SET_IP((Xt *)a_target);
   #endif
   }
   $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);
   #endif
   }
   
   \+
   )
   
   \ 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;  INST_TAIL; NEXT_P2;
 #endif  #endif
 }  }
Line 377  condbranch(?branch,f --,f83 question_bra Line 409  condbranch(?branch,f --,f83 question_bra
   
 \+xconds  \+xconds
   
 ?dup-?branch    ( #a_target f -- f )    new     question_dupe_question_branch  ?dup-?branch    ( #a_target f -- S:... )        new     question_dupe_question_branch
 ""The run-time procedure compiled by @code{?DUP-IF}.""  ""The run-time procedure compiled by @code{?DUP-IF}.""
 if (f==0) {  if (f==0) {
   sp++;  
   IF_spTOS(spTOS = sp[0]);  
 #ifdef NO_IP  #ifdef NO_IP
 INST_TAIL;  INST_TAIL;
 JUMP(a_target);  JUMP(a_target);
 #else  #else
 SET_IP((Xt *)a_target);  SET_IP((Xt *)a_target);
   INST_TAIL; NEXT_P2;  
 #endif  #endif
   } else {
   sp--;
   sp[0]=f;
 }  }
 SUPER_CONTINUE;  
   
 ?dup-0=-?branch ( #a_target f -- ) new  question_dupe_zero_equals_question_branch  ?dup-0=-?branch ( #a_target f -- S:... ) new    question_dupe_zero_equals_question_branch
 ""The run-time procedure compiled by @code{?DUP-0=-IF}.""  ""The run-time procedure compiled by @code{?DUP-0=-IF}.""
 /* the approach taken here of declaring the word as having the stack  
 effect ( f -- ) and correcting for it in the branch-taken case costs a  
 few cycles in that case, but is easy to convert to a CONDBRANCH  
 invocation */  
 if (f!=0) {  if (f!=0) {
   sp--;    sp--;
     sp[0]=f;
 #ifdef NO_IP  #ifdef NO_IP
   JUMP(a_target);    JUMP(a_target);
 #else  #else
   SET_IP((Xt *)a_target);    SET_IP((Xt *)a_target);
   NEXT;  
 #endif  #endif
 }  }
 SUPER_CONTINUE;  
   
 \+  \+
 \fhas? skiploopprims 0= [IF]  \fhas? skiploopprims 0= [IF]
Line 488  if (nstart == nlimit) { Line 514  if (nstart == nlimit) {
     JUMP(a_target);      JUMP(a_target);
 #else  #else
     SET_IP((Xt *)a_target);      SET_IP((Xt *)a_target);
     INST_TAIL; NEXT_P2;  
 #endif  #endif
 }  }
 SUPER_CONTINUE;  
 :  :
   2dup =    2dup =
   IF   r> swap rot >r >r    IF   r> swap rot >r >r
Line 511  if (nstart >= nlimit) { Line 535  if (nstart >= nlimit) {
     JUMP(a_target);      JUMP(a_target);
 #else  #else
     SET_IP((Xt *)a_target);      SET_IP((Xt *)a_target);
     INST_TAIL; NEXT_P2;  
 #endif  #endif
 }  }
 SUPER_CONTINUE;  
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
Line 534  if (ustart >= ulimit) { Line 556  if (ustart >= ulimit) {
 JUMP(a_target);  JUMP(a_target);
 #else  #else
 SET_IP((Xt *)a_target);  SET_IP((Xt *)a_target);
 INST_TAIL; NEXT_P2;  
 #endif  #endif
 }  }
 SUPER_CONTINUE;  
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
Line 557  if (nstart <= nlimit) { Line 577  if (nstart <= nlimit) {
 JUMP(a_target);  JUMP(a_target);
 #else  #else
 SET_IP((Xt *)a_target);  SET_IP((Xt *)a_target);
 INST_TAIL; NEXT_P2;  
 #endif  #endif
 }  }
 SUPER_CONTINUE;  
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
Line 580  if (ustart <= ulimit) { Line 598  if (ustart <= ulimit) {
 JUMP(a_target);  JUMP(a_target);
 #else  #else
 SET_IP((Xt *)a_target);  SET_IP((Xt *)a_target);
 INST_TAIL; NEXT_P2;  
 #endif  #endif
 }  }
 SUPER_CONTINUE;  
 :  :
  swap 2dup   swap 2dup
  r> swap >r swap >r   r> swap >r swap >r
Line 703  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 784  n = n1*n2; Line 809  n = n1*n2;
   
 /       ( n1 n2 -- n )          core    slash  /       ( n1 n2 -- n )          core    slash
 n = n1/n2;  n = n1/n2;
   if (CHECK_DIVISION_SW && n2 == 0)
     throw(BALL_DIVZERO);
   if (CHECK_DIVISION_SW && n2 == -1 && n1 == CELL_MIN)
     throw(BALL_RESULTRANGE);
   if (FLOORED_DIV && ((n1^n2) < 0) && (n1%n2 != 0))
     n--;
 :  :
  /mod nip ;   /mod nip ;
   
 mod     ( n1 n2 -- n )          core  mod     ( n1 n2 -- n )          core
 n = n1%n2;  n = n1%n2;
   if (CHECK_DIVISION_SW && n2 == 0)
     throw(BALL_DIVZERO);
   if (CHECK_DIVISION_SW && n2 == -1 && n1 == CELL_MIN)
     throw(BALL_RESULTRANGE);
   if(FLOORED_DIV && ((n1^n2) < 0) && n!=0) n += n2;
 :  :
  /mod drop ;   /mod drop ;
   
 /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_SW && n2 == 0)
     throw(BALL_DIVZERO);
   if (CHECK_DIVISION_SW && n2 == -1 && n1 == CELL_MIN)
     throw(BALL_RESULTRANGE);
   if (FLOORED_DIV && ((n1^n2) < 0) && n3!=0) {
     n4--;
     n3+=n2;
   }
 :  :
  >r s>d r> fm/mod ;   >r s>d r> fm/mod ;
   
   */mod   ( n1 n2 n3 -- n4 n5 )   core    star_slash_mod
   ""n1*n2=n3*n5+n4, with the intermediate result (n1*n2) being double.""
   #ifdef BUGGY_LL_MUL
   DCell d = mmul(n1,n2);
   #else
   DCell d = (DCell)n1 * (DCell)n2;
   #endif
   #ifdef BUGGY_LL_DIV
   DCell r = fmdiv(d,n3);
   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_SW && n3 == 0)
     throw(BALL_DIVZERO);
   if (FLOORED_DIV && ((DHI(d)^n3)<0) && n4!=0) {
     d5--;
     n4+=n3;
   }
   n5 = d5;
   if (CHECK_DIVISION && d5 != n5)
     throw(BALL_RESULTRANGE);
   #endif
   :
    >r m* r> fm/mod ;
   
   */      ( n1 n2 n3 -- n4 )      core    star_slash
   ""n4=(n1*n2)/n3, with the intermediate result being double.""
   #ifdef BUGGY_LL_MUL
   DCell d = mmul(n1,n2);
   #else
   DCell d = (DCell)n1 * (DCell)n2;
   #endif
   #ifdef BUGGY_LL_DIV
   DCell r = fmdiv(d,n3);
   n4=DLO(r);
   #else
   /* assumes that the processor uses either floored or symmetric division */
   DCell d4 = d/n3;
   if (CHECK_DIVISION_SW && n3 == 0)
     throw(BALL_DIVZERO);
   if (FLOORED_DIV && ((DHI(d)^n3)<0) && (d%n3)!=0)
     d4--;
   n4 = d4;
   if (CHECK_DIVISION && d4 != n4)
     throw(BALL_RESULTRANGE);
   #endif
   :
    */mod nip ;
   
 2*      ( n1 -- n2 )            core            two_star  2*      ( n1 -- n2 )            core            two_star
 ""Shift left by 1; also works on unsigned numbers""  ""Shift left by 1; also works on unsigned numbers""
 n2 = 2*n1;  n2 = 2*n1;
Line 810  division by 2 (note that @code{/} not ne Line 906  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 ;
   
 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_LONG_LONG  #ifdef BUGGY_LL_DIV
   #ifdef ASM_SM_SLASH_REM
   ASM_SM_SLASH_REM(d1.lo, d1.hi, n1, n2, n3);
   if (((DHI(d1)^n1)<0) && n2!=0) {
     if (CHECK_DIVISION && n3 == CELL_MIN)
       throw(BALL_RESULTRANGE);
     n3--;
     n2+=n1;
   }
   #else /* !defined(ASM_SM_SLASH_REM) */
 DCell r = fmdiv(d1,n1);  DCell r = fmdiv(d1,n1);
 n2=r.hi;  n2=DHI(r);
 n3=r.lo;  n3=DLO(r);
 #else  #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 (CHECK_DIVISION && 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 */  /* assumes that the processor uses either floored or symmetric division */
 n3 = d1/n1;  DCell d3 = d1/n1;
 n2 = d1%n1;  n2 = d1%n1;
   if (CHECK_DIVISION_SW && n1 == 0)
     throw(BALL_DIVZERO);
 /* note that this 1%-3>0 is optimized by the compiler */  /* note that this 1%-3>0 is optimized by the compiler */
 if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) {  if (1%-3>0 && ((DHI(d1)^n1)<0) && n2!=0) {
   n3--;    d3--;
   n2+=n1;    n2+=n1;
 }  }
   n3 = d3;
   if (CHECK_DIVISION && d3 != n3)
     throw(BALL_RESULTRANGE);
   #endif /* !defined(ASM_SM_SLASH_REM4) */
 #endif  #endif
 :  :
  dup >r dup 0< IF  negate >r dnegate r>  THEN   dup >r dup 0< IF  negate >r dnegate r>  THEN
Line 839  if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) Line 960  if (1%-3>0 && (d1<0) != (n1<0) && n2!=0)
   
 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_LONG_LONG  #ifdef BUGGY_LL_DIV
   #ifdef ASM_SM_SLASH_REM
   ASM_SM_SLASH_REM(d1.lo, d1.hi, n1, n2, n3);
   #else /* !defined(ASM_SM_SLASH_REM) */
 DCell r = smdiv(d1,n1);  DCell r = smdiv(d1,n1);
 n2=r.hi;  n2=DHI(r);
 n3=r.lo;  n3=DLO(r);
 #else  #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 */  /* assumes that the processor uses either floored or symmetric division */
 n3 = d1/n1;  DCell d3 = d1/n1;
 n2 = d1%n1;  n2 = d1%n1;
   if (CHECK_DIVISION_SW && n1 == 0)
     throw(BALL_DIVZERO);
 /* note that this 1%-3<0 is optimized by the compiler */  /* note that this 1%-3<0 is optimized by the compiler */
 if (1%-3<0 && (d1<0) != (n1<0) && n2!=0) {  if (1%-3<0 && ((DHI(d1)^n1)<0) && n2!=0) {
   n3++;    d3++;
   n2-=n1;    n2-=n1;
 }  }
   n3 = d3;
   if (CHECK_DIVISION && d3 != n3)
     throw(BALL_RESULTRANGE);
   #endif /* !defined(ASM_SM_SLASH_REM4) */
 #endif  #endif
 :  :
  over >r dup >r abs -rot   over >r dup >r abs -rot
Line 860  if (1%-3<0 && (d1<0) != (n1<0) && n2!=0) Line 994  if (1%-3<0 && (d1<0) != (n1<0) && n2!=0)
  r>        0< IF  swap negate swap  THEN ;   r>        0< IF  swap negate swap  THEN ;
   
 m*      ( n1 n2 -- d )          core    m_star  m*      ( n1 n2 -- d )          core    m_star
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LL_MUL
 d = mmul(n1,n2);  d = mmul(n1,n2);
 #else  #else
 d = (DCell)n1 * (DCell)n2;  d = (DCell)n1 * (DCell)n2;
Line 872  d = (DCell)n1 * (DCell)n2; Line 1006  d = (DCell)n1 * (DCell)n2;
   
 um*     ( u1 u2 -- ud )         core    u_m_star  um*     ( u1 u2 -- ud )         core    u_m_star
 /* use u* as alias */  /* use u* as alias */
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LL_MUL
 ud = ummul(u1,u2);  ud = ummul(u1,u2);
 #else  #else
 ud = (UDCell)u1 * (UDCell)u2;  ud = (UDCell)u1 * (UDCell)u2;
Line 888  ud = (UDCell)u1 * (UDCell)u2; Line 1022  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_LONG_LONG  #ifdef BUGGY_LL_DIV
   #ifdef ASM_UM_SLASH_MOD
   ASM_UM_SLASH_MOD(ud.lo, ud.hi, u1, u2, u3);
   #else /* !defined(ASM_UM_SLASH_MOD) */
 UDCell r = umdiv(ud,u1);  UDCell r = umdiv(ud,u1);
 u2=r.hi;  u2=DHI(r);
 u3=r.lo;  u3=DLO(r);
 #else  #endif /* !defined(ASM_UM_SLASH_MOD) */
 u3 = ud/u1;  #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;  u2 = ud%u1;
   if (CHECK_DIVISION_SW && u1 == 0)
     throw(BALL_DIVZERO);
   u3 = ud3;
   if (CHECK_DIVISION && ud3 != u3)
     throw(BALL_RESULTRANGE);
   #endif /* !defined(ASM_UM_SLASH_MOD4) */
 #endif  #endif
 :  :
    0 swap [ 8 cells 1 + ] literal 0     0 swap [ 8 cells 1 + ] literal 0
Line 907  u2 = ud%u1; Line 1054  u2 = ud%u1;
    and >r >r 2dup d+ swap r> + swap r> ;     and >r >r 2dup d+ swap r> + swap r> ;
   
 m+      ( d1 n -- d2 )          double          m_plus  m+      ( d1 n -- d2 )          double          m_plus
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LL_ADD
 d2.lo = d1.lo+n;  DLO_IS(d2, DLO(d1)+n);
 d2.hi = d1.hi - (n<0) + (d2.lo<d1.lo);  DHI_IS(d2, DHI(d1) - (n<0) + (DLO(d2)<DLO(d1)));
 #else  #else
 d2 = d1+n;  d2 = d1+n;
 #endif  #endif
Line 917  d2 = d1+n; Line 1064  d2 = d1+n;
  s>d d+ ;   s>d d+ ;
   
 d+      ( d1 d2 -- d )          double  d_plus  d+      ( d1 d2 -- d )          double  d_plus
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LL_ADD
 d.lo = d1.lo+d2.lo;  DLO_IS(d, DLO(d1) + DLO(d2));
 d.hi = d1.hi + d2.hi + (d.lo<d1.lo);  DHI_IS(d, DHI(d1) + DHI(d2) + (d.lo<DLO(d1)));
 #else  #else
 d = d1+d2;  d = d1+d2;
 #endif  #endif
Line 927  d = d1+d2; Line 1074  d = d1+d2;
  rot + >r tuck + swap over u> r> swap - ;   rot + >r tuck + swap over u> r> swap - ;
   
 d-      ( d1 d2 -- d )          double          d_minus  d-      ( d1 d2 -- d )          double          d_minus
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LL_ADD
 d.lo = d1.lo - d2.lo;  DLO_IS(d, DLO(d1) - DLO(d2));
 d.hi = d1.hi-d2.hi-(d1.lo<d2.lo);  DHI_IS(d, DHI(d1)-DHI(d2)-(DLO(d1)<DLO(d2)));
 #else  #else
 d = d1-d2;  d = d1-d2;
 #endif  #endif
Line 938  d = d1-d2; Line 1085  d = d1-d2;
   
 dnegate ( d1 -- d2 )            double  d_negate  dnegate ( d1 -- d2 )            double  d_negate
 /* use dminus as alias */  /* use dminus as alias */
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LL_ADD
 d2 = dnegate(d1);  d2 = dnegate(d1);
 #else  #else
 d2 = -d1;  d2 = -d1;
Line 948  d2 = -d1; Line 1095  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_LONG_LONG  #ifdef BUGGY_LL_SHIFT
 d2.lo = d1.lo<<1;  DLO_IS(d2, DLO(d1)<<1);
 d2.hi = (d1.hi<<1) | (d1.lo>>(CELL_BITS-1));  DHI_IS(d2, (DHI(d1)<<1) | (DLO(d1)>>(CELL_BITS-1)));
 #else  #else
 d2 = 2*d1;  d2 = 2*d1;
 #endif  #endif
Line 960  d2 = 2*d1; Line 1107  d2 = 2*d1;
 d2/     ( d1 -- d2 )            double          d_two_slash  d2/     ( d1 -- d2 )            double          d_two_slash
 ""Arithmetic shift right by 1.  For signed numbers this is a floored  ""Arithmetic shift right by 1.  For signed numbers this is a floored
 division by 2.""  division by 2.""
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LL_SHIFT
 d2.hi = d1.hi>>1;  DHI_IS(d2, DHI(d1)>>1);
 d2.lo= (d1.lo>>1) | (d1.hi<<(CELL_BITS-1));  DLO_IS(d2, (DLO(d1)>>1) | (DHI(d1)<<(CELL_BITS-1)));
 #else  #else
 d2 = d1>>1;  d2 = d1>>1;
 #endif  #endif
Line 988  w2 = ~w1; Line 1135  w2 = ~w1;
   
 rshift  ( u1 n -- u2 )          core    r_shift  rshift  ( u1 n -- u2 )          core    r_shift
 ""Logical shift right by @i{n} bits.""  ""Logical shift right by @i{n} bits.""
   u2 = u1>>n;  #ifdef BROKEN_SHIFT
     u2 = rshift(u1, n);
   #else
     u2 = u1 >> n;
   #endif
 :  :
     0 ?DO 2/ MAXI and LOOP ;      0 ?DO 2/ MAXI and LOOP ;
   
 lshift  ( u1 n -- u2 )          core    l_shift  lshift  ( u1 n -- u2 )          core    l_shift
   u2 = u1<<n;  #ifdef BROKEN_SHIFT
     u2 = lshift(u1, n);
   #else
     u2 = u1 << n;
   #endif
 :  :
     0 ?DO 2* LOOP ;      0 ?DO 2* LOOP ;
   
Line 1057  comparisons(u, u1 u2, u_, u1, u2, gforth Line 1212  comparisons(u, u1 u2, u_, u1, u2, gforth
 \ dcomparisons(prefix, args, prefix, arg1, arg2, wordsets...)  \ dcomparisons(prefix, args, prefix, arg1, arg2, wordsets...)
 define(dcomparisons,  define(dcomparisons,
 $1=     ( $2 -- f )             $6      $3equals  $1=     ( $2 -- f )             $6      $3equals
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LL_CMP
 f = FLAG($4.lo==$5.lo && $4.hi==$5.hi);  f = FLAG($4.lo==$5.lo && $4.hi==$5.hi);
 #else  #else
 f = FLAG($4==$5);  f = FLAG($4==$5);
 #endif  #endif
   
 $1<>    ( $2 -- f )             $7      $3not_equals  $1<>    ( $2 -- f )             $7      $3not_equals
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LL_CMP
 f = FLAG($4.lo!=$5.lo || $4.hi!=$5.hi);  f = FLAG($4.lo!=$5.lo || $4.hi!=$5.hi);
 #else  #else
 f = FLAG($4!=$5);  f = FLAG($4!=$5);
 #endif  #endif
   
 $1<     ( $2 -- f )             $8      $3less_than  $1<     ( $2 -- f )             $8      $3less_than
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LL_CMP
 f = FLAG($4.hi==$5.hi ? $4.lo<$5.lo : $4.hi<$5.hi);  f = FLAG($4.hi==$5.hi ? $4.lo<$5.lo : $4.hi<$5.hi);
 #else  #else
 f = FLAG($4<$5);  f = FLAG($4<$5);
 #endif  #endif
   
 $1>     ( $2 -- f )             $9      $3greater_than  $1>     ( $2 -- f )             $9      $3greater_than
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LL_CMP
 f = FLAG($4.hi==$5.hi ? $4.lo>$5.lo : $4.hi>$5.hi);  f = FLAG($4.hi==$5.hi ? $4.lo>$5.lo : $4.hi>$5.hi);
 #else  #else
 f = FLAG($4>$5);  f = FLAG($4>$5);
 #endif  #endif
   
 $1<=    ( $2 -- f )             gforth  $3less_or_equal  $1<=    ( $2 -- f )             gforth  $3less_or_equal
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LL_CMP
 f = FLAG($4.hi==$5.hi ? $4.lo<=$5.lo : $4.hi<=$5.hi);  f = FLAG($4.hi==$5.hi ? $4.lo<=$5.lo : $4.hi<=$5.hi);
 #else  #else
 f = FLAG($4<=$5);  f = FLAG($4<=$5);
 #endif  #endif
   
 $1>=    ( $2 -- f )             gforth  $3greater_or_equal  $1>=    ( $2 -- f )             gforth  $3greater_or_equal
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LL_CMP
 f = FLAG($4.hi==$5.hi ? $4.lo>=$5.lo : $4.hi>=$5.hi);  f = FLAG($4.hi==$5.hi ? $4.lo>=$5.lo : $4.hi>=$5.hi);
 #else  #else
 f = FLAG($4>=$5);  f = FLAG($4>=$5);
Line 1126  useraddr ( #u -- a_addr ) new Line 1281  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
   
 sp@     ( -- a_addr )           gforth          sp_fetch  sp@     ( S:... -- a_addr )             gforth          sp_fetch
 a_addr = sp+1;  a_addr = sp;
   
 sp!     ( a_addr -- )           gforth          sp_store  sp!     ( a_addr -- S:... )             gforth          sp_store
 sp = a_addr;  sp = a_addr;
 /* works with and without spTOS caching */  
   
 rp@     ( -- a_addr )           gforth          rp_fetch  rp@     ( -- a_addr )           gforth          rp_fetch
 a_addr = rp;  a_addr = rp;
Line 1146  rp = a_addr; Line 1300  rp = a_addr;
   
 \+floating  \+floating
   
 fp@     ( -- f_addr )   gforth  fp_fetch  fp@     ( f:... -- f_addr )     gforth  fp_fetch
 f_addr = fp;  f_addr = fp;
   
 fp!     ( f_addr -- )   gforth  fp_store  fp!     ( f_addr -- f:... )     gforth  fp_store
 fp = f_addr;  fp = f_addr;
   
 \+  \+
Line 1222  tuck ( w1 w2 -- w2 w1 w2 ) core-ext Line 1376  tuck ( w1 w2 -- w2 w1 w2 ) core-ext
 :  :
  swap over ;   swap over ;
   
 ?dup    ( w -- w )                      core    question_dupe  ?dup    ( w -- S:... w )        core    question_dupe
 ""Actually the stack effect is: @code{( w -- 0 | w w )}.  It performs a  ""Actually the stack effect is: @code{( w -- 0 | w w )}.  It performs a
 @code{dup} if w is nonzero.""  @code{dup} if w is nonzero.""
 if (w!=0) {  if (w!=0) {
   IF_spTOS(*sp-- = w;)  
 #ifndef USE_TOS  
   *--sp = w;    *--sp = w;
 #endif  
 }  }
 :  :
  dup IF dup THEN ;   dup IF dup THEN ;
   
 pick    ( u -- w )                      core-ext  pick    ( S:... u -- S:... w )          core-ext
 ""Actually the stack effect is @code{ x0 ... xu u -- x0 ... xu x0 }.""  ""Actually the stack effect is @code{ x0 ... xu u -- x0 ... xu x0 }.""
 w = sp[u+1];  w = sp[u];
 :  :
  1+ cells sp@ + @ ;   1+ cells sp@ + @ ;
   
Line 1538  n=1; Line 1689  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 1573  with the window size."" Line 1736  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 1590  SUPER_END; Line 1757  SUPER_END;
 return (Label *)n;  return (Label *)n;
   
 (system)        ( c_addr u -- wretval wior )    gforth  paren_system  (system)        ( c_addr u -- wretval wior )    gforth  paren_system
 #ifndef MSDOS  wretval = gforth_system(c_addr, u);  
 int old_tp=terminal_prepped;  
 deprep_terminal();  
 #endif  
 wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */  
 wior = IOR(wretval==-1 || (wretval==127 && errno != 0));  wior = IOR(wretval==-1 || (wretval==127 && errno != 0));
 #ifndef MSDOS  
 if (old_tp)  
   prep_terminal();  
 #endif  
   
 getenv  ( c_addr1 u1 -- c_addr2 u2 )    gforth  getenv  ( c_addr1 u1 -- c_addr2 u2 )    gforth
 ""The string @i{c-addr1 u1} specifies an environment variable. The string @i{c-addr2 u2}  ""The string @i{c-addr1 u1} specifies an environment variable. The string @i{c-addr2 u2}
Line 1607  is the host operating system's expansion Line 1766  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 1684  else Line 1843  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
 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{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 */
 IF_fpTOS(fp[0]=fpTOS);  gforth_FP=fp;
 FP=fp;  gforth_SP=sp;
 SP=sp;  
 ((void (*)())w)();  ((void (*)())w)();
 sp=SP;  sp=gforth_SP;
 fp=FP;  fp=gforth_FP;
 IF_spTOS(spTOS=sp[0]);  
 IF_fpTOS(fpTOS=fp[0]);  
   
 \+  \+
 \+file  \+file
Line 1828  if(dent == NULL) { Line 1984  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 1845  char * string = cstr(c_addr1, u1, 1); Line 2001  char * string = cstr(c_addr1, u1, 1);
 char * pattern = cstr(c_addr2, u2, 0);  char * pattern = cstr(c_addr2, u2, 0);
 flag = FLAG(!fnmatch(pattern, string, 0));  flag = FLAG(!fnmatch(pattern, string, 0));
   
   set-dir ( c_addr u -- wior )    gforth set_dir
   ""Change the current directory to @i{c-addr, u}.
   Return an error if this is not possible""
   wior = IOR(chdir(tilde_cstr(c_addr, u, 1)));
   
   get-dir ( c_addr1 u1 -- c_addr2 u2 )    gforth get_dir
   ""Store the current directory in the buffer specified by @{c-addr1, u1}.
   If the buffer size is not sufficient, return 0 0""
   c_addr2 = (Char *)getcwd((char *)c_addr1, u1);
   if(c_addr2 != NULL) {
     u2 = strlen((char *)c_addr2);
   } else {
     u2 = 0;
   }
   
 \+  \+
   
 newline ( -- c_addr u ) gforth  newline ( -- c_addr u ) gforth
Line 1858  char newline[] = { Line 2029  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 1887  dsystem = timeval2us(&usage.ru_stime); Line 2058  dsystem = timeval2us(&usage.ru_stime);
 struct timeval time1;  struct timeval time1;
 gettimeofday(&time1,NULL);  gettimeofday(&time1,NULL);
 duser = timeval2us(&time1);  duser = timeval2us(&time1);
 #ifndef BUGGY_LONG_LONG  dsystem = DZERO;
 dsystem = (DCell)0;  
 #else  
 dsystem=(DCell){0,0};  
 #endif  
 #endif  #endif
   
 \+  \+
Line 1903  dsystem=(DCell){0,0}; Line 2070  dsystem=(DCell){0,0};
 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_LONG_LONG  #ifdef BUGGY_LL_D2F
 extern double ldexp(double x, int exp);  extern double ldexp(double x, int exp);
 if (d.hi<0) {  if (DHI(d)<0) {
   #ifdef BUGGY_LL_ADD
   DCell d2=dnegate(d);    DCell d2=dnegate(d);
   r = -(ldexp((Float)d2.hi,CELL_BITS) + (Float)d2.lo);  #else
     DCell d2=-d;
   #endif
     r = -(ldexp((Float)DHI(d2),CELL_BITS) + (Float)DLO(d2));
 } else  } else
   r = ldexp((Float)d.hi,CELL_BITS) + (Float)d.lo;    r = ldexp((Float)DHI(d),CELL_BITS) + (Float)DLO(d);
 #else  #else
 r = d;  r = d;
 #endif  #endif
Line 1919  f>d ( r -- d )  float f_to_d Line 2093  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 1977  f** ( r1 r2 -- r3 ) float-ext f_star_sta Line 2154  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 2032  sig=ecvt(r, u, &decpt, &flag); Line 2221  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 */
     for (; sig[siglen-1]=='0'; siglen--);
       ;
 memcpy(c_addr,sig,siglen);  memcpy(c_addr,sig,siglen);
 memset(c_addr+siglen,f2?'0':' ',u-siglen);  memset(c_addr+siglen,f2?'0':' ',u-siglen);
   
 >float  ( c_addr u -- flag )    float   to_float  >float  ( c_addr u -- f:... flag )      float   to_float
 ""Actual stack effect: ( c_addr u -- r t | f ).  Attempt to convert the  ""Actual stack effect: ( c_addr u -- r t | f ).  Attempt to convert the
 character string @i{c-addr u} to internal floating-point  character string @i{c-addr u} to internal floating-point
 representation. If the string represents a valid floating-point number  representation. If the string represents a valid floating-point number
Line 2048  case and represents the floating-point n Line 2240  case and represents the floating-point n
 Float r;  Float r;
 flag = to_float(c_addr, u, &r);  flag = to_float(c_addr, u, &r);
 if (flag) {  if (flag) {
   IF_fpTOS(fp[0] = fpTOS);    fp--;
   fp += -1;    fp[0]=r;
   fpTOS = r;  
 }  }
   
 fabs    ( r1 -- r2 )    float-ext       f_abs  fabs    ( r1 -- r2 )    float-ext       f_abs
Line 2276  f>l ( r -- ) gforth f_to_l Line 2467  f>l ( r -- ) gforth f_to_l
 lp -= sizeof(Float);  lp -= sizeof(Float);
 *(Float *)lp = r;  *(Float *)lp = r;
   
 fpick   ( u -- r )              gforth  fpick   ( f:... u -- f:... r )          gforth
 ""Actually the stack effect is @code{ r0 ... ru u -- r0 ... ru r0 }.""  ""Actually the stack effect is @code{ r0 ... ru u -- r0 ... ru r0 }.""
 r = fp[u+1]; /* +1, because update of fp happens before this fragment */  r = fp[u];
 :  :
  floats fp@ + f@ ;   floats fp@ + f@ ;
   
Line 2316  u3 = 0; Line 2507  u3 = 0;
 #  endif  #  endif
 #endif  #endif
   
 wcall   ( u -- )        gforth  wcall   ( ... u -- ... )        gforth
 IF_fpTOS(fp[0]=fpTOS);  gforth_FP=fp;
 FP=fp;  sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &gforth_FP);
 sp=(Cell*)(SYSCALL(Cell*(*)(Cell *, void *))u)(sp, &FP);  fp=gforth_FP;
 fp=FP;  
 IF_spTOS(spTOS=sp[0];)  uw@ ( c_addr -- u )     gforth u_w_fetch
 IF_fpTOS(fpTOS=fp[0]);  ""@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 2354  av-double ( r -- ) gforth  av_double Line 2566  av-double ( r -- ) gforth  av_double
 av_double(alist, r);  av_double(alist, r);
   
 av-longlong     ( d -- )        gforth  av_longlong  av-longlong     ( d -- )        gforth  av_longlong
   #ifdef BUGGY_LL_SIZE
   av_longlong(alist, DLO(d));
   #else
 av_longlong(alist, d);  av_longlong(alist, d);
   #endif
   
 av-ptr  ( c_addr -- )   gforth  av_ptr  av-ptr  ( c_addr -- )   gforth  av_ptr
 av_ptr(alist, void*, c_addr);  av_ptr(alist, void*, c_addr);
Line 2373  lp += sizeof(Float); Line 2589  lp += sizeof(Float);
 av_double(alist, r);  av_double(alist, r);
   
 av-longlong-r   ( R:d -- )      gforth  av_longlong_r  av-longlong-r   ( R:d -- )      gforth  av_longlong_r
   #ifdef BUGGY_LL_SIZE
   av_longlong(alist, DLO(d));
   #else
 av_longlong(alist, d);  av_longlong(alist, d);
   #endif
   
 av-ptr-r        ( R:c_addr -- ) gforth  av_ptr_r  av-ptr-r        ( R:c_addr -- ) gforth  av_ptr_r
 av_ptr(alist, void*, c_addr);  av_ptr(alist, void*, c_addr);
   
 av-call-void    ( -- )  gforth  av_call_void  av-call-void    ( ... -- ... )  gforth  av_call_void
 SAVE_REGS  SAVE_REGS
 av_call(alist);  av_call(alist);
 REST_REGS  REST_REGS
   
 av-call-int     ( -- w )        gforth  av_call_int  av-call-int     ( ... -- ... w )        gforth  av_call_int
 SAVE_REGS  SAVE_REGS
 av_call(alist);  av_call(alist);
 REST_REGS  REST_REGS
 w = irv;  w = irv;
   
 av-call-float   ( -- r )        gforth  av_call_float  av-call-float   ( ... -- ... r )        gforth  av_call_float
 SAVE_REGS  SAVE_REGS
 av_call(alist);  av_call(alist);
 REST_REGS  REST_REGS
 r = frv;  r = frv;
   
 av-call-double  ( -- r )        gforth  av_call_double  av-call-double  ( ... -- ... r )        gforth  av_call_double
 SAVE_REGS  SAVE_REGS
 av_call(alist);  av_call(alist);
 REST_REGS  REST_REGS
 r = drv;  r = drv;
   
 av-call-longlong        ( -- d )        gforth  av_call_longlong  av-call-longlong        ( ... -- ... d )        gforth  av_call_longlong
 SAVE_REGS  SAVE_REGS
 av_call(alist);  av_call(alist);
 REST_REGS  REST_REGS
   #ifdef BUGGY_LONG_LONG
   DLO_IS(d, llrv);
   DHI_IS(d, 0);
   #else
 d = llrv;  d = llrv;
   #endif
   
 av-call-ptr     ( -- c_addr )   gforth  av_call_ptr  av-call-ptr     ( ... -- ... c_addr )   gforth  av_call_ptr
 SAVE_REGS  SAVE_REGS
 av_call(alist);  av_call(alist);
 REST_REGS  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
 d = va_arg_longlong(clist);  #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  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
 va_return_longlong(clist, d);  #ifdef BUGGY_LONG_LONG
   va_return_longlong(gforth_clist, d.lo);
   #else
   va_return_longlong(gforth_clist, d);
   #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
   *(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;  return 0;
   
 \+  \+
Line 2524  compile-prim1 ( a_prim -- ) gforth compi Line 2875  compile-prim1 ( a_prim -- ) gforth compi
 ""compile prim (incl. immargs) at @var{a_prim}""  ""compile prim (incl. immargs) at @var{a_prim}""
 compile_prim1(a_prim);  compile_prim1(a_prim);
   
 finish-code ( -- ) gforth finish_code  finish-code ( ... -- ... ) gforth finish_code
 ""Perform delayed steps in code generation (branch resolution, I-cache  ""Perform delayed steps in code generation (branch resolution, I-cache
 flushing).""  flushing).""
 IF_spTOS(sp[0]=spTOS); /* workaround for failing to save spTOS  /* The ... above are a workaround for a bug in gcc-2.95, which fails
                           (gcc-2.95.1, gforth-fast --enable-force-reg) */     to save spTOS (gforth-fast --enable-force-reg) */
 finish_code();  finish_code();
 IF_spTOS(spTOS=sp[0]);  
   
 forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode  forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode
 f = forget_dyncode(c_code);  f = forget_dyncode(c_code);
Line 2565  a_addr = groups; Line 2915  a_addr = groups;
   
 \g static_super  \g static_super
   
 ifdef(`M4_ENGINE_FAST',  ifdef(`STACK_CACHE_FILE',
 `include(peeprules.vmg)')  `include(peeprules.vmg)')
   
 \g end  \g end

Removed from v.1.150  
changed lines
  Added in v.1.200


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