[gforth] / gforth / prim  

gforth: gforth/prim

Diff for /gforth/prim between version 1.148 and 1.236

version 1.148, Thu Nov 6 09:47:49 2003 UTC version 1.236, Mon Oct 6 21:21:20 2008 UTC
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,2006,2007,2008 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 100 
Line 99 
 \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 107 
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 138 
Line 139 
   
 \ 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 
Line 192 
 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 201 
Line 202 
 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 246 
Line 261 
   
 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
 IF_spTOS(spTOS = sp[0]);  
 SUPER_END;  SUPER_END;
 EXEC(xt);  VM_JUMP(EXEC1(xt));
   
 perform ( a_addr -- )   gforth  perform ( a_addr -- )   gforth
 ""@code{@@ execute}.""  ""@code{@@ execute}.""
Line 259 
Line 276 
 #ifndef NO_IP  #ifndef NO_IP
 ip=IP;  ip=IP;
 #endif  #endif
 IF_spTOS(spTOS = sp[0]);  
 SUPER_END;  SUPER_END;
 EXEC(*(Xt *)a_addr);  VM_JUMP(EXEC1(*(Xt *)a_addr));
 :  :
  @ execute ;   @ execute ;
   
Line 284 
Line 300 
 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 
Line 309 
 #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 339 
Line 354 
 JUMP(a_target);  JUMP(a_target);
 #else  #else
 SET_IP((Xt *)a_target);  SET_IP((Xt *)a_target);
 INST_TAIL; NEXT_P2;  ifelse(condbranch_opt,`1',`INST_TAIL; NEXT_P2;',`/* condbranch_opt=0 */')
 #endif  #endif
 }  }
 SUPER_CONTINUE;  ifelse(condbranch_opt,`1',`SUPER_CONTINUE;',`/* condbranch_opt=0 */')
 $6  $6
   
 \+glocals  \+glocals
Line 356 
Line 371 
 JUMP(a_target);  JUMP(a_target);
 #else  #else
 SET_IP((Xt *)a_target);  SET_IP((Xt *)a_target);
 INST_TAIL; NEXT_P2;  ifelse(condbranch_opt,`1',`INST_TAIL; NEXT_P2;',`/* condbranch_opt=0 */')
 #endif  #endif
 }  }
 SUPER_CONTINUE;  ifelse(condbranch_opt,`1',`SUPER_CONTINUE;',`/* condbranch_opt=0 */')
   
 \+  \+
 )  )
Line 377 
Line 392 
   
 \+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 433 
Line 442 
 /* dependent upon two's complement arithmetic */  /* dependent upon two's complement arithmetic */
 Cell olddiff = n1-nlimit;  Cell olddiff = n1-nlimit;
 n2=n1+n;  n2=n1+n;
 ,if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */  ,if (((olddiff^(olddiff+n))    /* the limit is not crossed */
     || (olddiff^n)>=0          /* it is a wrap-around effect */) {       &(olddiff^n))             /* OR it is a wrap-around effect */
       >=0) { /* & is used to avoid having two branches for gforth-native */
 ,:  ,:
  r> swap   r> swap
  r> r> 2dup - >r   r> r> 2dup - >r
Line 463 
Line 473 
     newdiff = -newdiff;      newdiff = -newdiff;
 }  }
 n2=n1+n;  n2=n1+n;
 ,if (diff>=0 || newdiff<0) {  ,if (((~diff)|newdiff)<0) { /* use | to avoid two branches for gforth-native */
 ,)  ,)
   
 \+  \+
Line 487 
Line 497 
     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 510 
Line 518 
     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 533 
Line 539 
 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 556 
Line 560 
 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 579 
Line 581 
 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 609 
Line 609 
   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 702 
Line 702 
 :  :
  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 )  gforth
   ""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 722 
Line 731 
 \ 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 783 
Line 795 
   
 /       ( 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 ASM_SM_SLASH_REM
   ASM_SM_SLASH_REM(DLO(d), DHI(d), n3, n4, n5);
   if (FLOORED_DIV && ((DHI(d)^n3)<0) && n4!=0) {
     if (CHECK_DIVISION && n5 == CELL_MIN)
       throw(BALL_RESULTRANGE);
     n5--;
     n4+=n3;
   }
   #else
   DCell r = FLOORED_DIV ? fmdiv(d,n3) : smdiv(d,n3);
   n4=DHI(r);
   n5=DLO(r);
   #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 ASM_SM_SLASH_REM
   Cell remainder;
   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
   DCell r = FLOORED_DIV ? fmdiv(d,n3) : smdiv(d,n3);
   n4=DLO(r);
   #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 809 
Line 885 
 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 ASM_SM_SLASH_REM
 DCell r = fmdiv(d1,n1);  ASM_SM_SLASH_REM(DLO(d1), DHI(d1), n1, n2, n3);
 n2=r.hi;  if (((DHI(d1)^n1)<0) && n2!=0) {
 n3=r.lo;    if (CHECK_DIVISION && n3 == CELL_MIN)
 #else      throw(BALL_RESULTRANGE);
 /* assumes that the processor uses either floored or symmetric division */  
 n3 = d1/n1;  
 n2 = d1%n1;  
 /* note that this 1%-3>0 is optimized by the compiler */  
 if (1%-3>0 && (d1<0) != (n1<0) && n2!=0) {  
   n3--;    n3--;
   n2+=n1;    n2+=n1;
 }  }
 #endif  #else /* !defined(ASM_SM_SLASH_REM) */
   DCell r = fmdiv(d1,n1);
   n2=DHI(r);
   n3=DLO(r);
   #endif /* !defined(ASM_SM_SLASH_REM) */
 :  :
  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 838 
Line 913 
   
 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 ASM_SM_SLASH_REM
   ASM_SM_SLASH_REM(DLO(d1), DHI(d1), 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) */
 /* assumes that the processor uses either floored or symmetric division */  
 n3 = d1/n1;  
 n2 = d1%n1;  
 /* note that this 1%-3<0 is optimized by the compiler */  
 if (1%-3<0 && (d1<0) != (n1<0) && n2!=0) {  
   n3++;  
   n2-=n1;  
 }  
 #endif  
 :  :
  over >r dup >r abs -rot   over >r dup >r abs -rot
  dabs rot um/mod   dabs rot um/mod
Line 859 
Line 927 
  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 871 
Line 939 
   
 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 887 
Line 955 
   
 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 ASM_UM_SLASH_MOD
   ASM_UM_SLASH_MOD(DLO(ud), DHI(ud), 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;  
 u2 = ud%u1;  
 #endif  
 :  :
    0 swap [ 8 cells 1 + ] literal 0     0 swap [ 8 cells 1 + ] literal 0
    ?DO /modstep     ?DO /modstep
Line 906 
Line 973 
    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 916 
Line 983 
  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 926 
Line 993 
  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 937 
Line 1004 
   
 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 947 
Line 1014 
   
 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  d2 = DLSHIFT(d1,1);
 d2.lo = d1.lo<<1;  
 d2.hi = (d1.hi<<1) | (d1.lo>>(CELL_BITS-1));  
 #else  
 d2 = 2*d1;  
 #endif  
 :  :
  2dup d+ ;   2dup d+ ;
   
 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 987 
Line 1049 
   
 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.""
   #ifdef BROKEN_SHIFT
     u2 = rshift(u1, n);
   #else
   u2 = u1>>n;    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
   #ifdef BROKEN_SHIFT
     u2 = lshift(u1, n);
   #else
   u2 = u1<<n;    u2 = u1<<n;
   #endif
 :  :
     0 ?DO 2* LOOP ;      0 ?DO 2* LOOP ;
   
Line 1056 
Line 1126 
 \ 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 1125 
Line 1195 
 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 1145 
Line 1214 
   
 \+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 1221 
Line 1290 
 :  :
  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 1407 
Line 1473 
       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 1537 
Line 1608 
   
 \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  
   
 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;
   
   \+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;
 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 1582 
Line 1674 
 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;
 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 1606 
Line 1690 
 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 1641 
Line 1725 
 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 1683 
Line 1764 
 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{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);  IF_fpTOS(fp[0]=fpTOS);
 FP=fp;  gforth_FP=fp;
 SP=sp;  gforth_SP=sp;
   gforth_RP=rp;
   gforth_LP=lp;
   #ifdef HAS_LINKBACK
 ((void (*)())w)();  ((void (*)())w)();
 sp=SP;  #else
 fp=FP;  ((void (*)(void *))w)(gforth_pointers);
 IF_spTOS(spTOS=sp[0]);  #endif
   sp=gforth_SP;
   fp=gforth_FP;
   rp=gforth_RP;
   lp=gforth_LP;
 IF_fpTOS(fpTOS=fp[0]);  IF_fpTOS(fpTOS=fp[0]);
   
 \+  \+
Line 1712 
Line 1800 
 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 1827 
Line 1906 
   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 1844 
Line 1923 
 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 @i{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;
   }
   
   =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 1857 
Line 1955 
 '\r','\n'  '\r','\n'
 #endif  #endif
 };  };
 c_addr=newline;  c_addr=(Char *)newline;
 u=sizeof(newline);  u=sizeof(newline);
 :  :
  "newline count ;   "newline count ;
Line 1886 
Line 1984 
 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 1902 
Line 1996 
 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 1918 
Line 2019 
 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 1976 
Line 2080 
 ""@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 2006 
Line 2122 
 /* !! 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 2031 
Line 2147 
 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 2047 
Line 2166 
 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 2275 
Line 2393 
 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 2289 
Line 2407 
 \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)  #ifdef HAVE_LIBLTDL
   u2 = (UCell)lt_dlopen(tilde_cstr(c_addr1, u1, 1));
   #elif defined(HAVE_LIBDL) || defined(HAVE_DLOPEN)
 #ifndef RTLD_GLOBAL  #ifndef RTLD_GLOBAL
 #define RTLD_GLOBAL 0  #define RTLD_GLOBAL 0
 #endif  #endif
 u2=(UCell) dlopen(cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);  u2=(UCell) dlopen(tilde_cstr(c_addr1, u1, 1), RTLD_GLOBAL | RTLD_LAZY);
 #else  #else
 #  ifdef _WIN32  #  ifdef _WIN32
 u2 = (Cell) GetModuleHandle(cstr(c_addr1, u1, 1));  u2 = (Cell) GetModuleHandle(tilde_cstr(c_addr1, u1, 1));
 #  else  #  else
 #warning Define open-lib!  #warning Define open-lib!
 u2 = 0;  u2 = 0;
Line 2304 
Line 2424 
 #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 2315 
Line 2437 
 #  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);
 \+FFCALL  
   sw@ ( c_addr -- n )     gforth s_w_fetch
 av-start-void   ( c_addr -- )   gforth  av_start_void  ""@i{n} is the sign-extended 16-bit value stored at @i{c_addr}.""
 av_start_void(alist, c_addr);  n = *(Wyde*)(c_addr);
   
 av-start-int    ( c_addr -- )   gforth  av_start_int  w! ( w c_addr -- )      gforth w_store
 av_start_int(alist, c_addr, &irv);  ""Store the bottom 16 bits of @i{w} at @i{c_addr}.""
   *(Wyde*)(c_addr) = w;
 av-start-float  ( c_addr -- )   gforth  av_start_float  
 av_start_float(alist, c_addr, &frv);  ul@ ( c_addr -- u )     gforth u_l_fetch
   ""@i{u} is the zero-extended 32-bit value stored at @i{c_addr}.""
 av-start-double ( c_addr -- )   gforth  av_start_double  u = *(UTetrabyte*)(c_addr);
 av_start_double(alist, c_addr, &drv);  
   sl@ ( c_addr -- n )     gforth s_l_fetch
 av-start-longlong       ( c_addr -- )   gforth  av_start_longlong  ""@i{n} is the sign-extended 32-bit value stored at @i{c_addr}.""
 av_start_longlong(alist, c_addr, &llrv);  n = *(Tetrabyte*)(c_addr);
   
 av-start-ptr    ( c_addr -- )   gforth  av_start_ptr  l! ( w c_addr -- )      gforth l_store
 av_start_ptr(alist, c_addr, void*, &prv);  ""Store the bottom 32 bits of @i{w} at @i{c_addr}.""
   *(Tetrabyte*)(c_addr) = w;
 av-int  ( w -- )  gforth  av_int  
 av_int(alist, w);  lib-error ( -- c_addr u )       gforth  lib_error
   ""Error message for last failed @code{open-lib} or @code{lib-sym}.""
 av-float        ( r -- )        gforth  av_float  #ifdef HAVE_LIBLTDL
 av_float(alist, r);  c_addr = (Char *)lt_dlerror();
   u = (c_addr == NULL) ? 0 : strlen((char *)c_addr);
 av-double       ( r -- )        gforth  av_double  #else
 av_double(alist, r);  c_addr = "libltdl is not configured";
   u = strlen(c_addr);
 av-longlong     ( d -- )        gforth  av_longlong  #endif
 av_longlong(alist, d);  
   
 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  
 av_longlong(alist, d);  
   
 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  
 d = llrv;  
   
 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(engine_callback, (Xt *)a_ip);  
   
 va-start-void   ( -- )  gforth  va_start_void  
 va_start_void(clist);  
   
 va-start-int    ( -- )  gforth  va_start_int  
 va_start_int(clist);  
   
 va-start-longlong       ( -- )  gforth  va_start_longlong  
 va_start_longlong(clist);  
   
 va-start-ptr    ( -- )  gforth  va_start_ptr  
 va_start_ptr(clist, (char *));  
   
 va-start-float  ( -- )  gforth  va_start_float  
 va_start_float(clist);  
   
 va-start-double ( -- )  gforth  va_start_double  
 va_start_double(clist);  
   
 va-arg-int      ( -- w )        gforth  va_arg_int  
 w = va_arg_int(clist);  
   
 va-arg-longlong ( -- d )        gforth  va_arg_longlong  
 d = va_arg_longlong(clist);  
   
 va-arg-ptr      ( -- c_addr )   gforth  va_arg_ptr  
 c_addr = (char *)va_arg_ptr(clist,char*);  
   
 va-arg-float    ( -- r )        gforth  va_arg_float  
 r = va_arg_float(clist);  
   
 va-arg-double   ( -- r )        gforth  va_arg_double  
 r = va_arg_double(clist);  
   
 va-return-void ( -- )   gforth va_return_void  
 va_return_void(clist);  
 return 0;  
   
 va-return-int ( w -- )  gforth va_return_int  
 va_return_int(clist, w);  
 return 0;  
   
 va-return-ptr ( c_addr -- )     gforth va_return_ptr  
 va_return_ptr(clist, void *, c_addr);  
 return 0;  
   
 va-return-longlong ( d -- )     gforth va_return_longlong  
 va_return_longlong(clist, d);  
 return 0;  
   
 va-return-float ( r -- )        gforth va_return_float  
 va_return_float(clist, r);  
 return 0;  
   
 va-return-double ( r -- )       gforth va_return_double  
 va_return_double(clist, 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 2523 
Line 2485 
 ""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).""
   /* The ... above are a workaround for a bug in gcc-2.95, which fails
      to save spTOS (gforth-fast --enable-force-reg) */
 finish_code();  finish_code();
   
 forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode  forget-dyncode ( c_code -- f ) gforth-internal forget_dyncode
Line 2561 
Line 2525 
   
 \g static_super  \g static_super
   
 ifdef(`M4_ENGINE_FAST',  ifdef(`STACK_CACHE_FILE',
 `include(peeprules.vmg)')  `include(peeprules.vmg)')
   
 \g end  \g end

Generate output suitable for use with a patch program
Legend:
Removed from v.1.148  
changed lines
  Added in v.1.236
CVS Admin

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help