[gforth] / gforth / Attic / primitives  

gforth: gforth/Attic/primitives

Diff for /gforth/Attic/primitives between version 1.59 and 1.68

version 1.59, Tue Sep 10 16:08:39 1996 UTC version 1.68, Tue Mar 11 16:00:41 1997 UTC
Line 111 
Line 111 
 lit     -- w            gforth  lit     -- w            gforth
 w = (Cell)NEXT_INST;  w = (Cell)NEXT_INST;
 INC_IP(1);  INC_IP(1);
   :
    r> dup @ swap cell+ >r ;
   
 execute         xt --           core  execute         xt --           core
 ip=IP;  ip=IP;
Line 126 
Line 128 
 :  :
  @ execute ;   @ execute ;
   
   \+has-locals [IF]
   
 branch-lp+!#    --      gforth  branch_lp_plus_store_number  branch-lp+!#    --      gforth  branch_lp_plus_store_number
 /* this will probably not be used */  /* this will probably not be used */
 branch_adjust_lp:  branch_adjust_lp:
 lp += (Cell)(IP[1]);  lp += (Cell)(IP[1]);
 goto branch;  goto branch;
   
   \+[THEN]
   
 branch  --              gforth  branch  --              gforth
 branch:  branch:
 ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);  ip = (Xt *)(((Cell)IP)+(Cell)NEXT_INST);
Line 139 
Line 145 
 :  :
  r> dup @ + >r ;   r> dup @ + >r ;
   
 \ condbranch(forthname,restline,code)  \ condbranch(forthname,restline,code,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
 define(condbranch,  define(condbranch,
 $1      $2  $1      $2
Line 149 
Line 155 
 }  }
 else  else
     INC_IP(1);      INC_IP(1);
   $4
   
   \+has-locals [IF]
   
 $1-lp+!#        $2_lp_plus_store_number  $1-lp+!#        $2_lp_plus_store_number
 $3    goto branch_adjust_lp;  $3    goto branch_adjust_lp;
Line 156 
Line 165 
 else  else
     INC_IP(2);      INC_IP(2);
   
   \+[THEN]
 )  )
   
 condbranch(?branch,f --         f83     question_branch,  condbranch(?branch,f --         f83     question_branch,
 if (f==0) {  if (f==0) {
     IF_TOS(TOS = sp[0]);      IF_TOS(TOS = sp[0]);
 )  ,)
   
 \ we don't need an lp_plus_store version of the ?dup-stuff, because it  \ we don't need an lp_plus_store version of the ?dup-stuff, because it
 \ is only used in if's (yet)  \ is only used in if's (yet)
   
   \+has-xconds [IF]
   
 ?dup-?branch    f -- f  new     question_dupe_question_branch  ?dup-?branch    f -- f  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) {
Line 193 
Line 205 
 else  else
   INC_IP(1);    INC_IP(1);
   
   \+[THEN]
   
 condbranch((next),--            cmFORTH paren_next,  condbranch((next),--            cmFORTH paren_next,
 if ((*rp)--) {  if ((*rp)--) {
 )  ,:
    r> r> dup 1- >r
    IF dup @ + >r ELSE cell+ >r THEN ;)
   
 condbranch((loop),--            gforth  paren_loop,  condbranch((loop),--            gforth  paren_loop,
 Cell index = *rp+1;  Cell index = *rp+1;
 Cell limit = rp[1];  Cell limit = rp[1];
 if (index != limit) {  if (index != limit) {
     *rp = index;      *rp = index;
 )  ,:
    r> r> 1+ r> 2dup =
    IF >r 1- >r cell+ >r
    ELSE >r >r dup @ + >r THEN ;)
   
 condbranch((+loop),n --         gforth  paren_plus_loop,  condbranch((+loop),n --         gforth  paren_plus_loop,
 /* !! check this thoroughly */  /* !! check this thoroughly */
Line 210 
Line 229 
 /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */  /* sign bit manipulation and test: (x^y)<0 is equivalent to (x<0) != (y<0) */
 /* dependent upon two's complement arithmetic */  /* dependent upon two's complement arithmetic */
 Cell olddiff = index-rp[1];  Cell olddiff = index-rp[1];
 #ifndef undefined  
 if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */  if ((olddiff^(olddiff+n))>=0   /* the limit is not crossed */
     || (olddiff^n)>=0          /* it is a wrap-around effect */) {      || (olddiff^n)>=0          /* it is a wrap-around effect */) {
 #else  
 #ifndef MAXINT  
 #define MAXINT ((((Cell)1)<<(8*sizeof(Cell)-1))-1)  
 #endif  
 if(((olddiff^MAXINT) >= n) ^ ((olddiff+n) < 0)) {  
 #endif  
 #ifdef i386  #ifdef i386
     *rp += n;      *rp += n;
 #else  #else
     *rp = index + n;      *rp = index + n;
 #endif  #endif
     IF_TOS(TOS = sp[0]);      IF_TOS(TOS = sp[0]);
 )  ,:
    r> swap
    r> r> 2dup - >r
    2 pick r@ + r@ xor 0< 0=
    3 pick r> xor 0< 0= or
    IF    >r + >r dup @ + >r
    ELSE  >r >r drop cell+ >r THEN ;)
   
   \+has-xconds [IF]
   
 condbranch((-loop),u --         gforth  paren_minus_loop,  condbranch((-loop),u --         gforth  paren_minus_loop,
 /* !! check this thoroughly */  /* !! check this thoroughly */
Line 238 
Line 258 
     *rp = index - u;      *rp = index - u;
 #endif  #endif
     IF_TOS(TOS = sp[0]);      IF_TOS(TOS = sp[0]);
 )  ,)
   
 condbranch((s+loop),n --                gforth  paren_symmetric_plus_loop,  condbranch((s+loop),n --                gforth  paren_symmetric_plus_loop,
 ""The run-time procedure compiled by S+LOOP. It loops until the index  ""The run-time procedure compiled by S+LOOP. It loops until the index
Line 259 
Line 279 
     *rp = index + n;      *rp = index + n;
 #endif  #endif
     IF_TOS(TOS = sp[0]);      IF_TOS(TOS = sp[0]);
 )  ,)
   
   \+[THEN]
   
 unloop          --      core  unloop          --      core
 rp += 2;  rp += 2;
Line 278 
Line 300 
 *--rp = nlimit;  *--rp = nlimit;
 *--rp = nstart;  *--rp = nstart;
 :  :
  r> -rot swap >r >r >r ;   r> swap rot >r >r >r ;
   
 (?do)   nlimit nstart --        gforth  paren_question_do  (?do)   nlimit nstart --        gforth  paren_question_do
 *--rp = nlimit;  *--rp = nlimit;
Line 290 
Line 312 
 else {  else {
     INC_IP(1);      INC_IP(1);
 }  }
   :
     2dup =
     IF   r> swap rot >r >r
          dup @ + >r
     ELSE r> swap rot >r >r
          cell+ >r
     THEN ;                                \ --> CORE-EXT
   
   \+has-xconds [IF]
   
 (+do)   nlimit nstart --        gforth  paren_plus_do  (+do)   nlimit nstart --        gforth  paren_plus_do
 *--rp = nlimit;  *--rp = nlimit;
Line 301 
Line 332 
 else {  else {
     INC_IP(1);      INC_IP(1);
 }  }
   :
    swap 2dup
    r> swap >r swap >r
    >=
    IF
        dup @ +
    ELSE
        cell+
    THEN  >r ;
   
 (u+do)  ulimit ustart --        gforth  paren_u_plus_do  (u+do)  ulimit ustart --        gforth  paren_u_plus_do
 *--rp = ulimit;  *--rp = ulimit;
Line 312 
Line 352 
 else {  else {
     INC_IP(1);      INC_IP(1);
 }  }
   :
    swap 2dup
    r> swap >r swap >r
    u>=
    IF
        dup @ +
    ELSE
        cell+
    THEN  >r ;
   
 (-do)   nlimit nstart --        gforth  paren_minus_do  (-do)   nlimit nstart --        gforth  paren_minus_do
 *--rp = nlimit;  *--rp = nlimit;
Line 323 
Line 372 
 else {  else {
     INC_IP(1);      INC_IP(1);
 }  }
   :
    swap 2dup
    r> swap >r swap >r
    <=
    IF
        dup @ +
    ELSE
        cell+
    THEN  >r ;
   
 (u-do)  ulimit ustart --        gforth  paren_u_minus_do  (u-do)  ulimit ustart --        gforth  paren_u_minus_do
 *--rp = ulimit;  *--rp = ulimit;
Line 334 
Line 392 
 else {  else {
     INC_IP(1);      INC_IP(1);
 }  }
   :
    swap 2dup
    r> swap >r swap >r
    u<=
    IF
        dup @ +
    ELSE
        cell+
    THEN  >r ;
   
   \+[THEN]
   
 i       -- n            core  i       -- n            core
 n = *rp;  n = *rp;
   :
    rp@ cell+ @ ;
   
   i'      -- w            gforth          i_tick
   ""loop end value""
   w = rp[1];
   :
    rp@ cell+ cell+ @ ;
   
 j       -- n            core  j       -- n            core
 n = rp[2];  n = rp[2];
   :
    rp@ cell+ cell+ cell+ @ ;
   
 \ digit is high-level: 0/0%  k       -- n            gforth
   n = rp[4];
 (key)   -- n            gforth  paren_key  :
 fflush(stdout);   rp@ [ 5 cells ] Literal + @ ;
 /* !! noecho */  
 n = key();  
   
 key?    -- n            facility        key_q  
 fflush(stdout);  
 n = key_query;  
   
 form    -- urows ucols  gforth  \ digit is high-level: 0/0%
 ""The number of lines and columns in the terminal. These numbers may change  
 with the window size.""  
 /* we could block SIGWINCH here to get a consistent size, but I don't  
  think this is necessary or always beneficial */  
 urows=rows;  
 ucols=cols;  
   
 move    c_from c_to ucount --           core  move    c_from c_to ucount --           core
 memmove(c_to,c_from,ucount);  memmove(c_to,c_from,ucount);
Line 419 
Line 486 
  ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0   ?DO  dup c@ I c@ = WHILE  1+  LOOP  drop 0
  ELSE  c@ I c@ - unloop  THEN  -text-flag ;   ELSE  c@ I c@ - unloop  THEN  -text-flag ;
 : -text-flag ( n -- -1/0/1 )  : -text-flag ( n -- -1/0/1 )
  dup 0< IF  drop -1  ELSE  0>  IF  1  ELSE  0  THEN  THEN  ;   dup 0< IF  drop -1  ELSE  0>  1 and  THEN  ;
   
   toupper c1 -- c2        gforth
   c2 = toupper(c1);
   :
    dup [char] a - [ char z char a - 1 + ] Literal u<  bl and - ;
   
 capscomp        c_addr1 u c_addr2 -- n  new  capscomp        c_addr1 u c_addr2 -- n  new
 n = memcasecmp(c_addr1, c_addr2, u); /* !! use something that works in all locales */  n = memcasecmp(c_addr1, c_addr2, u); /* !! use something that works in all locales */
Line 429 
Line 501 
   n = 1;    n = 1;
 :  :
  swap bounds   swap bounds
  ?DO  dup c@ toupper I c@ toupper = WHILE  1+  LOOP  drop 0   ?DO  dup c@ I c@ <>
        IF  dup c@ toupper I c@ toupper =
        ELSE  true  THEN  WHILE  1+  LOOP  drop 0
  ELSE  c@ toupper I c@ toupper - unloop  THEN  -text-flag ;   ELSE  c@ toupper I c@ toupper - unloop  THEN  -text-flag ;
   
 -trailing       c_addr u1 -- c_addr u2          string  dash_trailing  -trailing       c_addr u1 -- c_addr u2          string  dash_trailing
Line 449 
Line 523 
 +       n1 n2 -- n              core    plus  +       n1 n2 -- n              core    plus
 n = n1+n2;  n = n1+n2;
   
 \ PFE has it differently, so let's better not define it  \ PFE-0.9.14 has it differently, but the next release will have it as follows
 \ under+        n1 n2 n3 -- n n2        gforth  under_plus  under+  n1 n2 n3 -- n n2        gforth  under_plus
 \ ""add @var{n3} to @var{n1} (giving @var{n})""  ""add @var{n3} to @var{n1} (giving @var{n})""
 \ /* and pfe */  n = n1+n3;
 \ n = n1+n3;  :
 \ :   rot + swap ;
 \  rot + swap ;  
   
 -       n1 n2 -- n              core    minus  -       n1 n2 -- n              core    minus
 n = n1-n2;  n = n1-n2;
Line 531 
Line 604 
 2/      n1 -- n2                core            two_slash  2/      n1 -- n2                core            two_slash
 /* !! is this still correct? */  /* !! is this still correct? */
 n2 = n1>>1;  n2 = n1>>1;
   :
    dup MINI and IF 1 ELSE 0 THEN
    [ bits/byte cell * 1- ] literal
    0 DO 2* swap dup 2* >r U-HIGHBIT and
        IF 1 ELSE 0 THEN or r> swap
    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: d1 = n3*n1+n2, n1>n2>=0 or 0>=n2>n1""  ""floored division: d1 = n3*n1+n2, n1>n2>=0 or 0>=n2>n1""
Line 594 
Line 673 
 #else  #else
 ud = (UDCell)u1 * (UDCell)u2;  ud = (UDCell)u1 * (UDCell)u2;
 #endif  #endif
   :
      >r >r 0 0 r> r> [ 8 cells ] literal 0
      DO
          over >r dup >r 0< and d2*+ drop
          r> 2* r> swap
      LOOP 2drop ;
   : d2*+ ( ud n -- ud+n c )
      over MINI
      and >r >r 2dup d+ swap r> + swap r> ;
   
 um/mod  ud u1 -- u2 u3          core    u_m_slash_mod  um/mod  ud u1 -- u2 u3          core    u_m_slash_mod
 #ifdef BUGGY_LONG_LONG  #ifdef BUGGY_LONG_LONG
Line 605 
Line 693 
 u2 = ud%u1;  u2 = ud%u1;
 #endif  #endif
 :  :
   dup IF  0 (um/mod)  THEN  nip ;     0 swap [ 8 cells 1 + ] literal 0
 : (um/mod)  ( ud ud -- ud u )     ?DO >r /modstep r>
   2dup >r >r  dup 0<     LOOP drop swap 1 rshift or swap ;
   IF    2drop 0  : /modstep ( ud c R: u -- ud-?u c R: u )
   ELSE  2dup d+  (um/mod)  2*  THEN     over I' u< 0= or IF I' - 1 ELSE 0 THEN  d2*+ ;
   -rot  r> r> 2over 2over  du<  : d2*+ ( ud n -- ud+n c )
   IF    2drop rot     over MINI
   ELSE  dnegate  d+  rot 1+  THEN ;     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_LONG_LONG
Line 680 
Line 768 
   
 or      w1 w2 -- w              core  or      w1 w2 -- w              core
 w = w1|w2;  w = w1|w2;
   :
    invert swap invert and invert ;
   
 xor     w1 w2 -- w              core  xor     w1 w2 -- w              core
 w = w1^w2;  w = w1^w2;
Line 687 
Line 777 
 invert  w1 -- w2                core  invert  w1 -- w2                core
 w2 = ~w1;  w2 = ~w1;
 :  :
  -1 xor ;   MAXU xor ;
   
 rshift  u1 n -- u2              core  rshift  u1 n -- u2              core
   u2 = u1>>n;    u2 = u1>>n;
   :
       0 ?DO 2/ MAXI and LOOP ;
   
 lshift  u1 n -- u2              core  lshift  u1 n -- u2              core
   u2 = u1<<n;    u2 = u1<<n;
   :
       0 ?DO 2* LOOP ;
   
 \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)  \ comparisons(prefix, args, prefix, arg1, arg2, wordsets...)
 define(comparisons,  define(comparisons,
 $1=     $2 -- f         $6      $3equals  $1=     $2 -- f         $6      $3equals
 f = FLAG($4==$5);  f = FLAG($4==$5);
   :
       [ char $1x char 0 = [IF]
           ] IF false ELSE true THEN [
       [ELSE]
           ] xor 0= [
       [THEN] ] ;
   
 $1<>    $2 -- f         $7      $3different  $1<>    $2 -- f         $7      $3different
 f = FLAG($4!=$5);  f = FLAG($4!=$5);
   :
       [ char $1x char 0 = [IF]
           ] IF true ELSE false THEN [
       [ELSE]
           ] xor 0<> [
       [THEN] ] ;
   
 $1<     $2 -- f         $8      $3less  $1<     $2 -- f         $8      $3less
 f = FLAG($4<$5);  f = FLAG($4<$5);
   :
       [ char $1x char 0 = [IF]
           ] MINI and 0<> [
       [ELSE] char $1x char u = [IF]
           ]   2dup xor 0<  IF nip ELSE - THEN 0<  [
           [ELSE]
               ] MINI xor >r MINI xor r> u< [
           [THEN]
       [THEN] ] ;
   
 $1>     $2 -- f         $9      $3greater  $1>     $2 -- f         $9      $3greater
 f = FLAG($4>$5);  f = FLAG($4>$5);
   :
       [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ]
       $1< ;
   
 $1<=    $2 -- f         gforth  $3less_or_equal  $1<=    $2 -- f         gforth  $3less_or_equal
 f = FLAG($4<=$5);  f = FLAG($4<=$5);
   :
       $1> 0= ;
   
 $1>=    $2 -- f         gforth  $3greater_or_equal  $1>=    $2 -- f         gforth  $3greater_or_equal
 f = FLAG($4>=$5);  f = FLAG($4>=$5);
   :
       [ char $1x char 0 = [IF] ] negate [ [ELSE] ] swap [ [THEN] ]
       $1<= ;
   
 )  )
   
Line 767 
Line 890 
   
 )  )
   
   \+has-dcomps [IF]
   
 dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth)  dcomparisons(d, d1 d2, d_, d1, d2, double, gforth, double, gforth)
 dcomparisons(d0, d, d_zero_, d, DZERO, double, gforth, double, gforth)  dcomparisons(d0, d, d_zero_, d, DZERO, double, gforth, double, gforth)
 dcomparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth)  dcomparisons(du, ud1 ud2, d_u_, ud1, ud2, gforth, gforth, double-ext, gforth)
   
   \+[THEN]
   
 within  u1 u2 u3 -- f           core-ext  within  u1 u2 u3 -- f           core-ext
 f = FLAG(u1-u2 < u3-u2);  f = FLAG(u1-u2 < u3-u2);
 :  :
Line 789 
Line 916 
 rp!     a_addr --               gforth          rpstore  rp!     a_addr --               gforth          rpstore
 rp = a_addr;  rp = a_addr;
   
   \+has-floats [IF]
   
 fp@     -- f_addr       gforth  fp_fetch  fp@     -- f_addr       gforth  fp_fetch
 f_addr = fp;  f_addr = fp;
   
 fp!     f_addr --       gforth  fp_store  fp!     f_addr --       gforth  fp_store
 fp = f_addr;  fp = f_addr;
   
   \+[THEN]
   
 ;s      --              gforth  semis  ;s      --              gforth  semis
 ip = (Xt *)(*rp++);  ip = (Xt *)(*rp++);
 NEXT_P0;  NEXT_P0;
   
 >r      w --            core    to_r  >r      w --            core    to_r
 *--rp = w;  *--rp = w;
   :
    (>r) ;
   : (>r)  rp@ cell+ @ rp@ ! rp@ cell+ ! ;
   
 r>      -- w            core    r_from  r>      -- w            core    r_from
 w = *rp++;  w = *rp++;
   :
 r@      -- w            core    r_fetch   rp@ cell+ @ rp@ @ rp@ cell+ ! (rdrop) rp@ ! ;
 /* use r as alias */  Create (rdrop) ' ;s A,
 /* make r@ an alias for i */  
 w = *rp;  
   
 rdrop   --              gforth  rdrop   --              gforth
 rp++;  rp++;
   :
 i'      -- w            gforth          i_tick   r> r> drop >r ;
 w=rp[1];  
   
 2>r     w1 w2 --        core-ext        two_to_r  2>r     w1 w2 --        core-ext        two_to_r
 *--rp = w1;  *--rp = w1;
 *--rp = w2;  *--rp = w2;
   :
    swap r> swap >r swap >r >r ;
   
 2r>     -- w1 w2        core-ext        two_r_from  2r>     -- w1 w2        core-ext        two_r_from
 w2 = *rp++;  w2 = *rp++;
 w1 = *rp++;  w1 = *rp++;
   :
    r> r> swap r> swap >r swap ;
   
 2r@     -- w1 w2        core-ext        two_r_fetch  2r@     -- w1 w2        core-ext        two_r_fetch
 w2 = rp[0];  w2 = rp[0];
 w1 = rp[1];  w1 = rp[1];
   :
    i' j ;
   
 2rdrop  --              gforth  two_r_drop  2rdrop  --              gforth  two_r_drop
 rp+=2;  rp+=2;
   :
    r> r> drop r> drop >r ;
   
 over    w1 w2 -- w1 w2 w1               core  over    w1 w2 -- w1 w2 w1               core
   :
    sp@ cell+ @ ;
   
 drop    w --            core  drop    w --            core
   :
    IF THEN ;
   
 swap    w1 w2 -- w2 w1          core  swap    w1 w2 -- w2 w1          core
   :
    >r (swap) ! r> (swap) @ ;
   Variable (swap)
   
 dup     w -- w w                core  dup     w -- w w                core
   :
    sp@ @ ;
   
 rot     w1 w2 w3 -- w2 w3 w1    core    rote  rot     w1 w2 w3 -- w2 w3 w1    core    rote
   :
   [ defined? (swap) [IF] ]
       (swap) ! (rot) ! >r (rot) @ (swap) @ r> ;
   Variable (rot)
   [ELSE] ]
       >r swap r> swap ;
   [THEN]
   
 -rot    w1 w2 w3 -- w3 w1 w2    gforth  not_rote  -rot    w1 w2 w3 -- w3 w1 w2    gforth  not_rote
 :  :
Line 847 
Line 1002 
   
 nip     w1 w2 -- w2             core-ext  nip     w1 w2 -- w2             core-ext
 :  :
  swap drop ;   >r drop r> ;
   
 tuck    w1 w2 -- w2 w1 w2       core-ext  tuck    w1 w2 -- w2 w1 w2       core-ext
 :  :
Line 882 
Line 1037 
   
 2swap   w1 w2 w3 w4 -- w3 w4 w1 w2      core    two_swap  2swap   w1 w2 w3 w4 -- w3 w4 w1 w2      core    two_swap
 :  :
  >r -rot r> -rot ;   rot >r rot r> ;
   
 2rot    w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2  double-ext      two_rote  2rot    w1 w2 w3 w4 w5 w6 -- w3 w4 w5 w6 w1 w2  double-ext      two_rote
 :  :
Line 906 
Line 1061 
   
 +!      n a_addr --             core    plus_store  +!      n a_addr --             core    plus_store
 *a_addr += n;  *a_addr += n;
   :
    tuck @ + swap ! ;
   
 c@      c_addr -- c             core    cfetch  c@      c_addr -- c             core    cfetch
 c = *c_addr;  c = *c_addr;
   :
   [ bigendian [IF] ]
       [ cell>bit 4 = [IF] ]
           dup [ 0 cell - ] Literal and @ swap 1 and
           IF  $FF and  ELSE  8>>  THEN  ;
       [ [ELSE] ]
           dup [ cell 1- ] literal and
           tuck - @ swap [ cell 1- ] literal xor
           0 ?DO 8>> LOOP $FF and
       [ [THEN] ]
   [ [ELSE] ]
       [ cell>bit 4 = [IF] ]
           dup [ 0 cell - ] Literal and @ swap 1 and
           IF  8>>  ELSE  $FF and  THEN
       [ [ELSE] ]
           dup [ cell  1- ] literal and
           tuck - @ swap
           0 ?DO 8>> LOOP 255 and
       [ [THEN] ]
   [ [THEN] ]
   ;
   : 8>> 2/ 2/ 2/ 2/  2/ 2/ 2/ 2/ ;
   
 c!      c c_addr --             core    cstore  c!      c c_addr --             core    cstore
 *c_addr = c;  *c_addr = c;
   :
   [ bigendian [IF] ]
       [ cell>bit 4 = [IF] ]
           tuck 1 and IF  $FF and  ELSE  8<<  THEN >r
           dup -2 and @ over 1 and cells masks + @ and
           r> or swap -2 and ! ;
           Create masks $00FF , $FF00 ,
       [ELSE] ]
           dup [ cell 1- ] literal and dup
           [ cell 1- ] literal xor >r
           - dup @ $FF r@ 0 ?DO 8<< LOOP invert and
           rot $FF and r> 0 ?DO 8<< LOOP or swap ! ;
       [THEN]
   [ELSE] ]
       [ cell>bit 4 = [IF] ]
           tuck 1 and IF  8<<  ELSE  $FF and  THEN >r
           dup -2 and @ over 1 and cells masks + @ and
           r> or swap -2 and ! ;
           Create masks $FF00 , $00FF ,
       [ELSE] ]
           dup [ cell 1- ] literal and dup >r
           - dup @ $FF r@ 0 ?DO 8<< LOOP invert and
           rot $FF and r> 0 ?DO 8<< LOOP or swap ! ;
       [THEN]
   [THEN]
   : 8<< 2* 2* 2* 2*  2* 2* 2* 2* ;
   
 2!      w1 w2 a_addr --         core    two_store  2!      w1 w2 a_addr --         core    two_store
 a_addr[0] = w2;  a_addr[0] = w2;
Line 928 
Line 1133 
 cell+   a_addr1 -- a_addr2      core    cell_plus  cell+   a_addr1 -- a_addr2      core    cell_plus
 a_addr2 = a_addr1+1;  a_addr2 = a_addr1+1;
 :  :
  [ cell ] Literal + ;   cell + ;
   
 cells   n1 -- n2                core  cells   n1 -- n2                core
 n2 = n1 * sizeof(Cell);  n2 = n1 * sizeof(Cell);
 :  :
  [ cell ]   [ cell
  [ 2/ dup ] [IF] 2* [THEN]   2/ dup [IF] ] 2* [ [THEN]
  [ 2/ dup ] [IF] 2* [THEN]   2/ dup [IF] ] 2* [ [THEN]
  [ 2/ dup ] [IF] 2* [THEN]   2/ dup [IF] ] 2* [ [THEN]
  [ 2/ dup ] [IF] 2* [THEN]   2/ dup [IF] ] 2* [ [THEN]
  [ drop ] ;   drop ] ;
   
 char+   c_addr1 -- c_addr2      core    care_plus  char+   c_addr1 -- c_addr2      core    care_plus
 c_addr2 = c_addr1 + 1;  c_addr2 = c_addr1 + 1;
Line 956 
Line 1161 
 :  :
  dup 1+ swap c@ ;   dup 1+ swap c@ ;
   
 (bye)   n --    gforth  paren_bye  
 return (Label *)n;  
   
 (system)        c_addr u -- wretval wior        gforth  peren_system  
 int old_tp=terminal_prepped;  
 deprep_terminal();  
 wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */  
 wior = IOR(wretval==-1 || (wretval==127 && errno != 0));  
 if (old_tp)  
   prep_terminal();  
   
 getenv  c_addr1 u1 -- c_addr2 u2        gforth  
 c_addr2 = getenv(cstr(c_addr1,u1,1));  
 u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));  
   
 open-pipe       c_addr u ntype -- wfileid wior  gforth  open_pipe  
 wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[ntype]); /* ~ expansion of 1st arg? */  
 wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */  
   
 close-pipe      wfileid -- wretval wior         gforth  close_pipe  
 wretval = pclose((FILE *)wfileid);  
 wior = IOR(wretval==-1);  
   
 time&date       -- nsec nmin nhour nday nmonth nyear    facility-ext    time_and_date  
 struct timeval time1;  
 struct timezone zone1;  
 struct tm *ltime;  
 gettimeofday(&time1,&zone1);  
 ltime=localtime((time_t *)&time1.tv_sec);  
 nyear =ltime->tm_year+1900;  
 nmonth=ltime->tm_mon+1;  
 nday  =ltime->tm_mday;  
 nhour =ltime->tm_hour;  
 nmin  =ltime->tm_min;  
 nsec  =ltime->tm_sec;  
   
 ms      n --    facility-ext  
 struct timeval timeout;  
 timeout.tv_sec=n/1000;  
 timeout.tv_usec=1000*(n%1000);  
 (void)select(0,0,0,0,&timeout);  
   
 allocate        u -- a_addr wior        memory  
 a_addr = (Cell *)malloc(u?u:1);  
 wior = IOR(a_addr==NULL);  
   
 free            a_addr -- wior          memory  
 free(a_addr);  
 wior = 0;  
   
 resize          a_addr1 u -- a_addr2 wior       memory  
 ""Change the size of the allocated area at @i{a_addr1} to @i{u}  
 address units, possibly moving the contents to a different  
 area. @i{a_addr2} is the address of the resulting area. If  
 @code{a_addr1} is 0, Gforth's (but not the standard) @code{resize}  
 @code{allocate}s @i{u} address units.""  
 /* the following check is not necessary on most OSs, but it is needed  
    on SunOS 4.1.2. */  
 if (a_addr1==NULL)  
   a_addr2 = (Cell *)malloc(u);  
 else  
   a_addr2 = (Cell *)realloc(a_addr1, u);  
 wior = IOR(a_addr2==NULL);      /* !! Define a return code */  
   
 (f83find)       c_addr u f83name1 -- f83name2   new     paren_f83find  (f83find)       c_addr u f83name1 -- f83name2   new     paren_f83find
 for (; f83name1 != NULL; f83name1 = f83name1->next)  for (; f83name1 != NULL; f83name1 = f83name1->next)
   if (F83NAME_COUNT(f83name1)==u &&    if ((UCell)F83NAME_COUNT(f83name1)==u &&
       memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)        memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
     break;      break;
 f83name2=f83name1;  f83name2=f83name1;
 :  :
  BEGIN  dup  WHILE      BEGIN  dup WHILE  (find-samelen)  dup  WHILE
         >r dup r@ cell+ c@ $1F and =          >r 2dup r@ cell+ char+ capscomp  0=
         IF  2dup r@ cell+ char+ capscomp  0=          IF  2drop r>  EXIT  THEN
             IF  2drop r>  EXIT  THEN  THEN  
         r> @          r> @
  REPEAT  nip nip ;      REPEAT  THEN  nip nip ;
   : (find-samelen) ( u f83name1 -- u f83name2/0 )
       BEGIN  2dup cell+ c@ $1F and <> WHILE  @  dup 0= UNTIL  THEN ;
   
   \+has-hash [IF]
   
 (hashfind)      c_addr u a_addr -- f83name2     new     paren_hashfind  (hashfind)      c_addr u a_addr -- f83name2     new     paren_hashfind
 F83Name *f83name1;  F83Name *f83name1;
Line 1041 
Line 1185 
 {  {
    f83name1=(F83Name *)(a_addr[1]);     f83name1=(F83Name *)(a_addr[1]);
    a_addr=(Cell *)(a_addr[0]);     a_addr=(Cell *)(a_addr[0]);
    if (F83NAME_COUNT(f83name1)==u &&     if ((UCell)F83NAME_COUNT(f83name1)==u &&
        memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)         memcasecmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
      {       {
         f83name2=f83name1;          f83name2=f83name1;
Line 1064 
Line 1208 
 {  {
    f83name1=(F83Name *)(a_addr[1]);     f83name1=(F83Name *)(a_addr[1]);
    a_addr=(Cell *)(a_addr[0]);     a_addr=(Cell *)(a_addr[0]);
    if (F83NAME_COUNT(f83name1)==u &&     if ((UCell)F83NAME_COUNT(f83name1)==u &&
        memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */)         memcmp(c_addr, f83name1->name, u)== 0 /* or inline? */)
      {       {
         f83name2=f83name1;          f83name2=f83name1;
Line 1113 
Line 1257 
   7 c, 5 c, 5 c, 5 c, 5 c,  6 c, 5 c, 5 c, 5 c, 5 c,    7 c, 5 c, 5 c, 5 c, 5 c,  6 c, 5 c, 5 c, 5 c, 5 c,
   7 c, 5 c, 5 c,    7 c, 5 c, 5 c,
   
   \+[THEN]
   
 (parse-white)   c_addr1 u1 -- c_addr2 u2        gforth  paren_parse_white  (parse-white)   c_addr1 u1 -- c_addr2 u2        gforth  paren_parse_white
 /* use !isgraph instead of isspace? */  /* use !isgraph instead of isspace? */
 Char *endp = c_addr1+u1;  Char *endp = c_addr1+u1;
Line 1133 
Line 1279 
  BEGIN  dup  WHILE  over c@ bl >   WHILE  1 /string   BEGIN  dup  WHILE  over c@ bl >   WHILE  1 /string
  REPEAT  THEN  nip - ;   REPEAT  THEN  nip - ;
   
   aligned         c_addr -- a_addr        core
   a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell)));
   :
    [ cell 1- ] Literal + [ -1 cells ] Literal and ;
   
   faligned        c_addr -- f_addr        float   f_aligned
   f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float)));
   :
    [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;
   
   >body           xt -- a_addr    core    to_body
   a_addr = PFA(xt);
   :
       2 cells + ;
   
   >code-address           xt -- c_addr            gforth  to_code_address
   ""c_addr is the code address of the word xt""
   /* !! This behaves installation-dependently for DOES-words */
   c_addr = (Address)CODE_ADDRESS(xt);
   :
       @ ;
   
   >does-code      xt -- a_addr            gforth  to_does_code
   ""If xt ist the execution token of a defining-word-defined word,
   a_addr is the start of the Forth code after the DOES>;
   Otherwise a_addr is 0.""
   a_addr = (Cell *)DOES_CODE(xt);
   :
       cell+ @ ;
   
   code-address!           c_addr xt --            gforth  code_address_store
   ""Creates a code field with code address c_addr at xt""
   MAKE_CF(xt, c_addr);
   CACHE_FLUSH(xt,PFA(0));
   :
       ! ;
   
   does-code!      a_addr xt --            gforth  does_code_store
   ""creates a code field at xt for a defining-word-defined word; a_addr
   is the start of the Forth code after DOES>""
   MAKE_DOES_CF(xt, a_addr);
   CACHE_FLUSH(xt,PFA(0));
   :
       dodoes: over ! cell+ ! ;
   
   does-handler!   a_addr --       gforth  does_handler_store
   ""creates a DOES>-handler at address a_addr. a_addr usually points
   just behind a DOES>.""
   MAKE_DOES_HANDLER(a_addr);
   CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE);
   :
       drop ;
   
   /does-handler   -- n    gforth  slash_does_handler
   ""the size of a does-handler (includes possible padding)""
   /* !! a constant or environmental query might be better */
   n = DOES_HANDLER_SIZE;
   :
       2 cells ;
   
   threading-method        -- n    gforth  threading_method
   ""0 if the engine is direct threaded. Note that this may change during
   the lifetime of an image.""
   #if defined(DOUBLY_INDIRECT)
   n=2;
   #else
   # if defined(DIRECT_THREADED)
   n=0;
   # else
   n=1;
   # endif
   #endif
   :
    1 ;
   
   \+has-os [IF]
   
   (key)   -- n            gforth  paren_key
   fflush(stdout);
   /* !! noecho */
   n = key();
   
   key?    -- n            facility        key_q
   fflush(stdout);
   n = key_query;
   
   stdout  -- wfileid      gforth
   wfileid = (Cell)stdout;
   
   stderr  -- wfileid      gforth
   wfileid = (Cell)stderr;
   
   form    -- urows ucols  gforth
   ""The number of lines and columns in the terminal. These numbers may change
   with the window size.""
   /* we could block SIGWINCH here to get a consistent size, but I don't
    think this is necessary or always beneficial */
   urows=rows;
   ucols=cols;
   
   flush-icache    c_addr u --     gforth  flush_icache
   ""Make sure that the instruction cache of the processor (if there is
   one) does not contain stale data at @var{c_addr} and @var{u} bytes
   afterwards. @code{END-CODE} performs a @code{flush-icache}
   automatically. Caveat: @code{flush-icache} might not work on your
   installation; this is usually the case if direct threading is not
   supported on your machine (take a look at your @file{machine.h}) and
   your machine has a separate instruction cache. In such cases,
   @code{flush-icache} does nothing instead of flushing the instruction
   cache.""
   FLUSH_ICACHE(c_addr,u);
   
   (bye)   n --    gforth  paren_bye
   return (Label *)n;
   
   (system)        c_addr u -- wretval wior        gforth  peren_system
   int old_tp=terminal_prepped;
   deprep_terminal();
   wretval=system(cstr(c_addr,u,1)); /* ~ expansion on first part of string? */
   wior = IOR(wretval==-1 || (wretval==127 && errno != 0));
   if (old_tp)
     prep_terminal();
   
   getenv  c_addr1 u1 -- c_addr2 u2        gforth
   c_addr2 = getenv(cstr(c_addr1,u1,1));
   u2 = (c_addr2 == NULL ? 0 : strlen(c_addr2));
   
   open-pipe       c_addr u ntype -- wfileid wior  gforth  open_pipe
   wfileid=(Cell)popen(cstr(c_addr,u,1),fileattr[ntype]); /* ~ expansion of 1st arg? */
   wior = IOR(wfileid==0); /* !! the man page says that errno is not set reliably */
   
   close-pipe      wfileid -- wretval wior         gforth  close_pipe
   wretval = pclose((FILE *)wfileid);
   wior = IOR(wretval==-1);
   
   time&date       -- nsec nmin nhour nday nmonth nyear    facility-ext    time_and_date
   struct timeval time1;
   struct timezone zone1;
   struct tm *ltime;
   gettimeofday(&time1,&zone1);
   ltime=localtime((time_t *)&time1.tv_sec);
   nyear =ltime->tm_year+1900;
   nmonth=ltime->tm_mon+1;
   nday  =ltime->tm_mday;
   nhour =ltime->tm_hour;
   nmin  =ltime->tm_min;
   nsec  =ltime->tm_sec;
   
   ms      n --    facility-ext
   struct timeval timeout;
   timeout.tv_sec=n/1000;
   timeout.tv_usec=1000*(n%1000);
   (void)select(0,0,0,0,&timeout);
   
   allocate        u -- a_addr wior        memory
   a_addr = (Cell *)malloc(u?u:1);
   wior = IOR(a_addr==NULL);
   
   free            a_addr -- wior          memory
   free(a_addr);
   wior = 0;
   
   resize          a_addr1 u -- a_addr2 wior       memory
   ""Change the size of the allocated area at @i{a_addr1} to @i{u}
   address units, possibly moving the contents to a different
   area. @i{a_addr2} is the address of the resulting area. If
   @code{a_addr1} is 0, Gforth's (but not the standard) @code{resize}
   @code{allocate}s @i{u} address units.""
   /* the following check is not necessary on most OSs, but it is needed
      on SunOS 4.1.2. */
   if (a_addr1==NULL)
     a_addr2 = (Cell *)malloc(u);
   else
     a_addr2 = (Cell *)realloc(a_addr1, u);
   wior = IOR(a_addr2==NULL);      /* !! Define a return code */
   
   strerror        n -- c_addr u   gforth
   c_addr = strerror(n);
   u = strlen(c_addr);
   
   strsignal       n -- c_addr u   gforth
   c_addr = strsignal(n);
   u = strlen(c_addr);
   
   call-c  w --    gforth  call_c
   ""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
   variables @code{SP} and @code{FP}.""
   /* This is a first attempt at support for calls to C. This may change in
      the future */
   IF_FTOS(fp[0]=FTOS);
   FP=fp;
   SP=sp;
   ((void (*)())w)();
   sp=SP;
   fp=FP;
   IF_TOS(TOS=sp[0]);
   IF_FTOS(FTOS=fp[0]);
   
   \+[THEN] ( has-os ) has-files [IF]
   
 close-file      wfileid -- wior         file    close_file  close-file      wfileid -- wior         file    close_file
 wior = IOR(fclose((FILE *)wfileid)==EOF);  wior = IOR(fclose((FILE *)wfileid)==EOF);
   
Line 1142 
Line 1489 
   
 create-file     c_addr u ntype -- w2 wior       file    create_file  create-file     c_addr u ntype -- w2 wior       file    create_file
 Cell    fd;  Cell    fd;
 fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_RDWR|O_TRUNC, 0666);  fd = open(tilde_cstr(c_addr, u, 1), O_CREAT|O_TRUNC|ufileattr[ntype], 0666);
 if (fd != -1) {  if (fd != -1) {
   w2 = (Cell)fdopen(fd, fileattr[ntype]);    w2 = (Cell)fdopen(fd, fileattr[ntype]);
   wior = IOR(w2 == 0);    wior = IOR(w2 == 0);
Line 1211 
Line 1558 
   u2=0;    u2=0;
 }  }
   
   \+[THEN]  has-files [IF] -1 [ELSE] has-os [THEN] [IF]
   
 write-file      c_addr u1 wfileid -- wior       file    write_file  write-file      c_addr u1 wfileid -- wior       file    write_file
 /* !! fwrite does not guarantee enough */  /* !! fwrite does not guarantee enough */
 {  {
   Cell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);    UCell u2 = fwrite(c_addr, sizeof(Char), u1, (FILE *)wfileid);
   wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));    wior = FILEIO(u2<u1 && ferror((FILE *)wfileid));
   if (wior)    if (wior)
     clearerr((FILE *)wfileid);      clearerr((FILE *)wfileid);
Line 1225 
Line 1574 
 if (wior)  if (wior)
   clearerr((FILE *)wfileid);    clearerr((FILE *)wfileid);
   
   \+[THEN]  has-files [IF]
   
 flush-file      wfileid -- wior         file-ext        flush_file  flush-file      wfileid -- wior         file-ext        flush_file
 wior = IOR(fflush((FILE *) wfileid)==EOF);  wior = IOR(fflush((FILE *) wfileid)==EOF);
   
Line 1252 
Line 1603 
   wior=0;    wior=0;
 }  }
   
 stdout  -- wfileid      gforth  \+[THEN] ( has-files ) has-floats [IF]
 wfileid = (Cell)stdout;  
   
 stderr  -- wfileid      gforth  
 wfileid = (Cell)stderr;  
   
 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)
Line 1527 
Line 1874 
 dfloats         n1 -- n2        float-ext       d_floats  dfloats         n1 -- n2        float-ext       d_floats
 n2 = n1*sizeof(DFloat);  n2 = n1*sizeof(DFloat);
   
 aligned         c_addr -- a_addr        core  
 a_addr = (Cell *)((((Cell)c_addr)+(sizeof(Cell)-1))&(-sizeof(Cell)));  
 :  
  [ cell 1- ] Literal + [ -1 cells ] Literal and ;  
   
 faligned        c_addr -- f_addr        float   f_aligned  
 f_addr = (Float *)((((Cell)c_addr)+(sizeof(Float)-1))&(-sizeof(Float)));  
 :  
  [ 1 floats 1- ] Literal + [ -1 floats ] Literal and ;  
   
 sfaligned       c_addr -- sf_addr       float-ext       s_f_aligned  sfaligned       c_addr -- sf_addr       float-ext       s_f_aligned
 sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat)));  sf_addr = (SFloat *)((((Cell)c_addr)+(sizeof(SFloat)-1))&(-sizeof(SFloat)));
 :  :
Line 1552 
Line 1889 
 \ !! how about environmental queries DIRECT-THREADED,  \ !! how about environmental queries DIRECT-THREADED,
 \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */  \   INDIRECT-THREADED, TOS-CACHED, FTOS-CACHED, CODEFIELD-DOES */
   
 >body           xt -- a_addr    core    to_body  
 a_addr = PFA(xt);  
   
 >code-address           xt -- c_addr            gforth  to_code_address  
 ""c_addr is the code address of the word xt""  
 /* !! This behaves installation-dependently for DOES-words */  
 c_addr = CODE_ADDRESS(xt);  
   
 >does-code      xt -- a_addr            gforth  to_does_code  
 ""If xt ist the execution token of a defining-word-defined word,  
 a_addr is the start of the Forth code after the DOES>;  
 Otherwise a_addr is 0.""  
 a_addr = (Cell *)DOES_CODE(xt);  
   
 code-address!           c_addr xt --            gforth  code_address_store  
 ""Creates a code field with code address c_addr at xt""  
 MAKE_CF(xt, c_addr);  
 CACHE_FLUSH(xt,PFA(0));  
   
 does-code!      a_addr xt --            gforth  does_code_store  
 ""creates a code field at xt for a defining-word-defined word; a_addr  
 is the start of the Forth code after DOES>""  
 MAKE_DOES_CF(xt, a_addr);  
 CACHE_FLUSH(xt,PFA(0));  
   
 does-handler!   a_addr --       gforth  does_handler_store  
 ""creates a DOES>-handler at address a_addr. a_addr usually points  
 just behind a DOES>.""  
 MAKE_DOES_HANDLER(a_addr);  
 CACHE_FLUSH(a_addr,DOES_HANDLER_SIZE);  
   
 /does-handler   -- n    gforth  slash_does_handler  
 ""the size of a does-handler (includes possible padding)""  
 /* !! a constant or environmental query might be better */  
 n = DOES_HANDLER_SIZE;  
   
 threading-method        -- n    gforth  threading_method  
 ""0 if the engine is direct threaded.""  
 #if defined(DIRECT_THREADED)  
 n=0;  
 #else  
 n=1;  
 #endif  
   
 flush-icache    c_addr u --     gforth  flush_icache  
 ""Make sure that the instruction cache of the processor (if there is  
 one) does not contain stale data at @var{c_addr} and @var{u} bytes  
 afterwards. @code{END-CODE} performs a @code{flush-icache}  
 automatically. Caveat: @code{flush-icache} might not work on your  
 installation; this is usually the case if direct threading is not  
 supported on your machine (take a look at your @file{machine.h}) and  
 your machine has a separate instruction cache. In such cases,  
 @code{flush-icache} does nothing instead of flushing the instruction  
 cache.""  
 FLUSH_ICACHE(c_addr,u);  
   
 toupper c1 -- c2        gforth  
 c2 = toupper(c1);  
   
 \ local variable implementation primitives  \ local variable implementation primitives
   \+[THEN] ( has-floats ) has-locals [IF]
   
 @local#         -- w    gforth  fetch_local_number  @local#         -- w    gforth  fetch_local_number
 w = *(Cell *)(lp+(Cell)NEXT_INST);  w = *(Cell *)(lp+(Cell)NEXT_INST);
 INC_IP(1);  INC_IP(1);
Line 1628 
Line 1908 
 @local3 -- w    new     fetch_local_twelve  @local3 -- w    new     fetch_local_twelve
 w = *(Cell *)(lp+3*sizeof(Cell));  w = *(Cell *)(lp+3*sizeof(Cell));
   
   \+has-floats [IF]
   
 f@local#        -- r    gforth  f_fetch_local_number  f@local#        -- r    gforth  f_fetch_local_number
 r = *(Float *)(lp+(Cell)NEXT_INST);  r = *(Float *)(lp+(Cell)NEXT_INST);
 INC_IP(1);  INC_IP(1);
Line 1638 
Line 1920 
 f@local1        -- r    new     f_fetch_local_eight  f@local1        -- r    new     f_fetch_local_eight
 r = *(Float *)(lp+1*sizeof(Float));  r = *(Float *)(lp+1*sizeof(Float));
   
   \+[THEN]
   
 laddr#          -- c_addr       gforth  laddr_number  laddr#          -- c_addr       gforth  laddr_number
 /* this can also be used to implement lp@ */  /* this can also be used to implement lp@ */
 c_addr = (Char *)(lp+(Cell)NEXT_INST);  c_addr = (Char *)(lp+(Cell)NEXT_INST);
Line 1666 
Line 1950 
 lp -= sizeof(Cell);  lp -= sizeof(Cell);
 *(Cell *)lp = w;  *(Cell *)lp = w;
   
   \+has-floats [IF]
   
 f>l     r --    gforth  f_to_l  f>l     r --    gforth  f_to_l
 lp -= sizeof(Float);  lp -= sizeof(Float);
 *(Float *)lp = r;  *(Float *)lp = r;
   
 up!     a_addr --       gforth  up_store  \+[THEN]  [THEN] \ has-locals
 up0=up=(char *)a_addr;  
   
 call-c  w --    gforth  call_c  up!     a_addr --       gforth  up_store
 ""Call the C function pointed to by @i{w}. The C function has to  UP=up=(char *)a_addr;
 access the stack itself. The stack pointers are exported in the gloabl  :
 variables @code{SP} and @code{FP}.""   up ! ;
 /* This is a first attempt at support for calls to C. This may change in  Variable UP
    the future */  
 IF_FTOS(fp[0]=FTOS);  
 FP=fp;  
 SP=sp;  
 ((void (*)())w)();  
 sp=SP;  
 fp=FP;  
 IF_TOS(TOS=sp[0]);  
 IF_FTOS(FTOS=fp[0]);  
   
 strerror        n -- c_addr u   gforth  
 c_addr = strerror(n);  
 u = strlen(c_addr);  
   
 strsignal       n -- c_addr u   gforth  
 c_addr = strsignal(n);  
 u = strlen(c_addr);  

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

Powered by ViewCVS 1.0-dev 		(Powered by ViewCVS)

ViewCVS and CVS Help